home *** CD-ROM | disk | FTP | other *** search
/ Internet Info 1994 March / Internet Info CD-ROM (Walnut Creek) (March 1994).iso / networking / terms / kermit / c / tripos.bcp < prev    next >
Encoding:
BCPL source  |  1988-08-16  |  76.2 KB  |  3,012 lines
  1. FILE TRIPOS.BCP
  2. ---------------
  3. /* This file contains the source of Tripos Kermit. There are two distinct
  4.    source files here, with the break point marked with a line of asterisks.
  5.    You should edit the file to split it into its two constituent parts.
  6.  
  7.    WARNING, This program uses the console driver to do I/O to the terminal,
  8.    and serial line. The code puts the driver in 1 character per packet mode,
  9.    and the kernal must be modified to allow up to 96 outstanding packets. It
  10.    also is helpful to remove the code which strips the top bit, but explicit
  11.    use of parity (e.g. space) will overcome this problem.
  12. */
  13.    
  14.  
  15. // This is the main TRIPOS Kermit source file
  16. SECTION "Kermit"
  17.  
  18. /*********************************************************************
  19.  
  20.       KK    KK  EEEEEEEE  RRRRRRR   MM    MM  IIIIIIII  TTTTTTTT
  21.       KK   KK   EEEEEEEE  RRRRRRRR  MMM  MMM  IIIIIIII  TTTTTTTT
  22.       KK  KK    EE        RR    RR  MMMMMMMM     II        TT
  23.       KKKK      EEEEEE    RRRRRRRR  MM MM MM     II        TT
  24.       KK KK     EE        RRRRRRR   MM    MM     II        TT
  25.       KK  KK    EE        RR  RR    MM    MM     II        TT
  26.       KK   KK   EEEEEEEE  RR   RR   MM    MM  IIIIIIII     TT
  27.       KK    KK  EEEEEEEE  RR    RR  MM    MM  IIIIIIII     TT
  28.  
  29. *********************************************************************/
  30.  
  31. /*
  32.    This is TRIPOS KERMIT
  33.          by C.G. Selwyn
  34.             Elec.Eng. Dept.
  35.             Bath University
  36.  
  37.    It is based on a translated version of the
  38.    generic KERMIT in the protocol manual.
  39.    However the following additions have been made
  40.  
  41. Update 1.
  42. ---------
  43. 1) Correct handling of an upto seven character Send-init packet
  44. 2) Command parser to handle user commands e.g. SET command etc.
  45. 3) Server mode
  46. 4) Image mode
  47. 5) Take command
  48.  
  49. Update 2. (08-NOV-84)
  50. ---------------------
  51. 6) Multilink interface
  52.  
  53. Update 3. (17-JUL-85)
  54. ---------------------
  55. 7) Changed Multilink Interface
  56. 8) Message packet handling
  57. 9) Server bug corrected
  58.  
  59. Update 4. (30-SEP-85)
  60. ---------------------
  61. 10) Filename parsing of names with '-' fixed
  62. 11) SETDIR command added
  63. 12) DO command added
  64.  
  65. Update 5. (03-FEB-86) IWJS
  66. --------------------------
  67. 13) Fixed incorrect padding request
  68.  
  69. */
  70.  
  71. GET "libhdr"
  72. GET "clihdr"
  73. GET "iohdr"
  74. GET "prshdr"
  75. GET "manhdr"
  76.  
  77. MANIFEST
  78. $( version  =  1
  79.    update   =  5
  80.  
  81.    maxpack  =  94    // Maximum packet size
  82.    soh      =  1     // Start of header
  83.    sp       =  32    // ASCII space
  84.    cr       =  13    // ASCII Carriage return
  85.    del      =  127   // ASCII rubout
  86.    ctrld    =  4
  87.    brkchr   =  ctrld // Default escape character
  88.  
  89.    maxtry   =  5     // Time I try a packet
  90.    myquote  =  '#'   // Quote character I will use
  91.    mypad    =  0     // Number of padding characters I will need
  92.    mypchar  =  0     // Padding character I will need
  93.    myeol    =  '*N'  // End of line character I will need
  94.    mytime   =  5     // Seconds after which I should be timed out
  95.    myquote8 =  '&'   // My 8 bit quoting character
  96.    maxtim   =  20    // Maximum Time out interval
  97.    mintim   =  2     // Minimum time out interval
  98.    maxfiles =  10    // Maximum no. of files in argument string
  99.    null     =  0
  100.    xoff     =  'S'-'@'
  101.    xon      =  'Q'-'@'
  102.  
  103.    argvl    =  50
  104.  
  105.    w.s      =  0
  106.    w.r      =  1
  107.    w.c      =  2
  108.    w.e      =  3
  109.    w.help   =  4
  110.    w.set    =  5
  111.    w.status =  6
  112.    w.show   =  7
  113.    w.server =  8
  114.    w.finish =  9
  115.    w.get    = 10
  116.    w.take   = 11
  117.    w.endstream = 12
  118.    w.setdir = 13
  119.    w.setdir2= 14
  120.    w.do     = 15
  121.  
  122.    p.plen   = 0
  123.    p.pad    = 1
  124.    p.padchar= 2
  125.    p.eol    = 3
  126.    p.sop    = 4
  127.    p.quote  = 5
  128.    p.timeout= 6
  129.    p.upb    = 6
  130.  
  131.    s1  = 1     ; s2   = s1+1  ; s3  = s2+1 ; s4  = s3+1  ; s5  = s4+1
  132.    s6  = s5+1  ; s7   = s6+1  ; s8  = s7+1 ; s9  = s8+1  ; sa  = s9+1
  133.    sb  = sa+1  ; sc   = sb+1  ; sd  = sc+1 ; s10 = sd+1  ; s10a= s10+1
  134.    s11 = s10a+1; s11a = s11+1
  135.    s31 = s11a+1
  136.    s51 = s31+1 ; s52  = s51+1 ; s53 = s52+1; s54 = s53+1
  137.    s55 = s54+1 ; s56  = s55+1
  138.    s531= s56+1 ; s532 = s531+1; s533=s532+1; s534= s533+1; s535= s534+1
  139.    s536= s535+1; s537 = s536+1; s538=s537+1
  140.    s5a = s538+1; s5b  = s5a+1 ; s53a=s5b+1 ; s53b= s53a+1
  141.    sc1 = s53b+1
  142.    sd1 = sc1+1
  143.    term= sd1+1
  144.    file=term+1; f1    = file+1;f2    = f1+1 ; f3 = f2+1  ; f4  = f3+1
  145.    f5  = f4+1 ; f6    = f5+1  ; f7   = f6+1 ; f8 = f7+1 ; dirname = f8+1
  146.    anychs = dirname+1
  147.  
  148.    ticksperminute = tickspersecond * 60
  149.    ticksperhour   = ticksperminute * 60
  150.    ticksperday    = ticksperhour   * 24
  151.  
  152.    bitsperbyte    = 10
  153.  
  154.    act.connect    = 1020
  155.    act.disconnect = 1021
  156. $)
  157.  
  158. GLOBAL
  159. $( size            :  ug    // Size of present data
  160. // ug+1
  161. // ug+2
  162. // ug+3           // Used by prshdr
  163. // ug+4
  164. // ug+5
  165.    n               :  ug+6  // Message number
  166.  
  167.    r.packet.length :  ug+7  // Maximum recieve packet size
  168.    r.pad           :  ug+8  // How much padding to send
  169.    r.padchar       :  ug+9  // Padding character to be received
  170.    r.eol           :  ug+10 // End of line character to be received
  171.    r.sop           :  ug+11 // Start of receive packet character
  172.    r.quote         :  ug+12 // Receive quote character
  173.    r.timeout       :  ug+13 // Timeout on receive
  174.  
  175.    s.packet.length :  ug+14 // Maximum send packet size
  176.    s.pad           :  ug+15 // How much padding to send
  177.    s.padchar       :  ug+16 // Padding character to be sent
  178.    s.eol           :  ug+17 // End of line character to be sent
  179.    s.sop           :  ug+18 // Start of packet character to send
  180.    s.quote         :  ug+19 // Send quote character
  181.    s.timeout       :  ug+20 // Timeout for my send packet
  182.  
  183.    serving         :  ug+21 // Server mode
  184.    numtry          :  ug+22 // Times this packet  retried
  185.    oldtry          :  ug+23 // Times previous packet retried
  186.    fd              :  ug+24 // Scb pointer for read/write file
  187.    remfd           :  ug+25 // Console handler number of remote line
  188.    image           :  ug+26 // True means 8 bit mode
  189.    pakcnt          :  ug+27 // No. of packets
  190.    debug           :  ug+28 // Means we're debugging (Unlucky for some)
  191.  
  192.    astate          :  ug+29 // Present state of the automaton
  193.    escchr          :  ug+30 // Connect command escape character
  194.    filelist        :  ug+31 // List of files to be sent
  195.    filnam          :  ug+32 // Current file name
  196.    recpkt          :  ug+33 // Receive packet buffer
  197.    packet          :  ug+34 // Packet buffer
  198.    clk.p           :  ug+35 // Clock packet environment
  199.    clk.l           :  ug+36
  200.    filecnt         :  ug+37 // Output file count
  201.    sys.pktwait     :  ug+38
  202.    end.connect     :  ug+39 // Flag to end connect mode
  203.    consin          :  ug+40 // Console input stream
  204.    consout         :  ug+41 // Console output stream
  205.    sc.read.pkt     :  ug+42 // Single character read packet
  206.    got.sc.pkt      :  ug+43 // Single character packet queued flag
  207.    remote          :  ug+44 // True means we're a remote kermit
  208.    local           :  ug+45 // User kermit flag
  209.    remote.delay    :  ug+46 // Delay to sending Send-Init packet if remote
  210.    parse.vec       :  ug+47 // Current parameter table vector used by the parser
  211.    argv            :  ug+48 // Argument vector
  212.    argvp           :  ug+49 // Next free slot in argument vector
  213.    numfiles        :  ug+50 // No. of files to be sent
  214.    command         :  ug+51 // sic.
  215.    cbuf            :  ug+52 // Command line buffer
  216.    cptr            :  ug+53 // Command line buffer pointer
  217.    starttime       :  ug+54 // Start time of last transfer
  218.    finishtime      :  ug+55 // Finish time of last transfer
  219.    bytes           :  ug+56 // No. of bytes transfered
  220.    quote8          :  ug+57 // 8-bit quoting character
  221.    quote8ing       :  ug+58 // Flag 8-bit quoting operational
  222.    word            :  ug+59 // Current word to send if in image mode
  223.    wptr            :  ug+60 // Pointer into above
  224.    reporting       :  ug+61 // Progress reporting flag
  225.    currentin       :  ug+62 // Current command input stream
  226.    reclevel        :  ug+63 // Recursion level
  227.    erroring        :  ug+64 // Error flag
  228.    sendchars       :  ug+65 // Current routine for sending a buffer
  229.    mlink           :  ug+66 // True if connected to multilink
  230.    close           :  ug+67 // Closedown routine
  231.    message.pkts    :  ug+68 // Queue of unprocessed message pkts
  232.    orig.dir        :  ug+69 // Original currentdir
  233.    my.setname      :  ug+70 // Dir name
  234. $)
  235.  
  236. /*
  237.    S T A R T    of   T R I P O S   K E R M I T
  238.  
  239.     Initialise and call the handle routine to execute
  240.     the current command input stream
  241. */
  242.  
  243. LET start() BE
  244. $( LET rp = VEC maxpack/bytesperword
  245.    LET pk = VEC maxpack/bytesperword
  246.    LET srp = VEC pkt.arg1-1
  247.    LET avec = VEC argvl
  248.    LET c = VEC 80/bytesperword
  249.    LET tvec = VEC 1
  250.    LET setname = VEC 40
  251.  
  252.    starttime := tvec
  253.    finishtime := tvec+1
  254.    cbuf := c
  255.    argv := avec
  256.    pakcnt := 0
  257.    reclevel := 0
  258.    erroring := FALSE
  259.    mlink := 0
  260.    message.pkts := 0
  261.    orig.dir := currentdir
  262.    my.setname := setname
  263.    copystring(cli.setname,my.setname)
  264.  
  265.    consout := findterminal()
  266.    consin  := consout
  267.    currentin := consin
  268.    finishtime!0 := -1
  269.    filecnt := 0
  270.    recpkt := rp
  271.    packet := pk
  272.    fd := 0        // No file open
  273.  
  274.    escchr := brkchr
  275.    remote.delay := 5
  276.    image := FALSE
  277.    quote8ing := FALSE
  278.    quote8 := myquote8
  279.    reporting := TRUE
  280.  
  281.    s.eol := cr
  282.    s.packet.length := maxpack
  283.    s.quote := myquote
  284.    s.pad := 0
  285.    s.padchar := null
  286.    s.sop := soh
  287.    s.timeout := 5
  288.  
  289.    r.eol := myeol
  290.    r.packet.length := maxpack
  291.    r.quote := myquote
  292.    r.pad := mypad
  293.    r.padchar := mypchar
  294.    r.sop := soh
  295.    r.timeout := 5
  296.  
  297.    local := TRUE
  298.    remote := ~local
  299.    serving := FALSE
  300.    sys.pktwait := pktwait
  301.    pktwait := my.pktwait
  302.  
  303.    sc.read.pkt := srp
  304.    sc.read.pkt!pkt.link := notinuse
  305.    sc.read.pkt!pkt.id   := remfd
  306.    sc.read.pkt!pkt.type := act.sc.read
  307.    qpkt(sc.read.pkt)
  308.    got.sc.pkt := FALSE
  309.  
  310.    writef("Tripos Kermit - Version %N.%N*N",version,update)
  311.    initialise()
  312.  
  313.    handle()
  314.  
  315.    cons(writef,"Workspace used = %N%%*N",distat())
  316.    close()
  317. $)
  318.  
  319. /*
  320.    H A N D L E
  321.  
  322.     This routine handles the parsing and actioning of the
  323.     current command input stream.
  324.     Take commands are a recursive call to handle().
  325. */
  326.  
  327. AND handle() BE
  328. $( filecnt := 0
  329.    erroring := FALSE
  330.    selectinput(currentin)
  331.    selectoutput(consout)
  332.    IF currentin = consin THEN
  333.       writef("Kermit-68K (%S) > *E",remote->"Remote","Local")
  334.    command := -1
  335.    readline(cbuf)
  336.    cptr := 1
  337.    TEST do.parse() THEN
  338.    $(
  339.       SWITCHON command INTO
  340.       $(
  341.       CASE w.set :
  342.          do.set()
  343.          ENDCASE
  344.  
  345.       CASE w.status :
  346.          do.status()
  347.          ENDCASE
  348.  
  349.       CASE w.show :
  350.          do.show()
  351.          ENDCASE
  352.  
  353.       CASE w.c :
  354.          IF reclevel ~= 0 THEN
  355.          $( writes("Can't connect from take file*N")
  356.             erroring := TRUE
  357.             ENDCASE
  358.          $)
  359.          IF remote THEN
  360.          $( writes("Can't connect if remote*N")
  361.             erroring := TRUE
  362.             ENDCASE
  363.          $)
  364.          connect()
  365.          ENDCASE
  366.  
  367.       CASE w.s :
  368.       CASE w.r :
  369.          handle.sr()
  370.          ENDCASE
  371.  
  372.       CASE w.get :
  373.          TEST local THEN do.get()
  374.          ELSE
  375.             writes("Can't perform get if remote*N")
  376.          ENDCASE
  377.  
  378.       CASE w.endstream :
  379.          IF reclevel ~= 0 THEN RETURN     // If executing file
  380.       CASE w.e :                          // Otherwise treat as end command
  381.          BREAK
  382.  
  383.       CASE w.help :
  384.          show.help()
  385.          ENDCASE
  386.  
  387.       CASE w.server :
  388.          TEST remote THEN
  389.             TEST serve() THEN BREAK
  390.             ELSE ENDCASE
  391.          ELSE
  392.          $( erroring := TRUE
  393.             writes("Can't serve if local kermit*N") $)
  394.          ENDCASE
  395.  
  396.       CASE w.finish :
  397.          TEST local THEN
  398.             remote.finish()
  399.          ELSE
  400.          $( erroring := TRUE
  401.             writes("Can't issue finish if remote*N") $)
  402.          ENDCASE
  403.  
  404.       CASE w.take :
  405.          $( LET newin = findinput(argv!0)
  406.             LET oldin = currentin
  407.             IF newin = 0 THEN
  408.             $( writef("Can't find file %S*N",argv!0)
  409.                erroring := TRUE
  410.                ENDCASE
  411.             $)
  412.             currentin := newin
  413.             reclevel := reclevel+1
  414.             handle()
  415.             reclevel := reclevel-1
  416.             selectinput(currentin)
  417.             endread()
  418.             currentin := oldin
  419.             ENDCASE
  420.          $)
  421.       $)
  422.    $)
  423.    ELSE
  424.    $( erroring := TRUE
  425.       writes("Bad command*N")
  426.    $)
  427.    IF erroring & (reclevel ~= 0) THEN RETURN
  428. $) REPEAT
  429.  
  430. /*
  431.    s e r v e r
  432.  
  433.    Loop collecting commands from the other end
  434.    and executing them
  435. */
  436.  
  437. AND serve() = VALOF
  438. $( LET num,len = ?,?
  439.    LET r = ?
  440.  
  441.    rem.sc.mode(TRUE)
  442.    n := 0
  443.    serving := TRUE
  444.  
  445.    $( numfiles := 1
  446.       filecnt := 0
  447.       SWITCHON rpack(@len,@num,recpkt) INTO
  448.       $(
  449.       CASE 'S' :
  450.          rpar(recpkt,len)
  451.          len := spar(packet)
  452.          report(TRUE)
  453.          spack('Y',n,len,packet)
  454.          oldtry := numtry
  455.          numtry := 0
  456.          n := (n+1) REM 64
  457.          datstamp(starttime)
  458.  
  459.          TEST recsw() THEN
  460.             datstamp(finishtime)
  461.          ELSE finishtime!0 := -1
  462.          ENDCASE
  463.  
  464.       CASE 'R' :
  465.          filnam := argv
  466.          FOR i = 0 TO len-1 DO
  467.             filnam%(i+1) := recpkt%i
  468.          filnam%0 := len
  469.          filelist := @filnam
  470.          datstamp(starttime)
  471.          bytes := 0
  472.  
  473.          TEST sendsw() THEN
  474.             datstamp(finishtime)
  475.          ELSE finishtime!0 := -1
  476.          ENDCASE
  477.  
  478.       CASE 'G' :                          // Generic commands
  479.          SWITCHON recpkt%0 INTO
  480.          $(
  481.          CASE 'F' :                       // Finish
  482.             FOR i = 1 TO 4 DO packet%(i-1) := "OK.*N"%i
  483.             spack('Y',n,4,packet)
  484.             r := FALSE                    // Don't exit
  485.             BREAK
  486.          CASE 'L' :                       // Logout
  487.             FOR i = 1 TO 4 DO packet%(i-1) := "OK.*N"%i
  488.             spack('Y',n,4,packet)
  489.             r := TRUE                     // Exit
  490.             BREAK
  491.          $)
  492.  
  493.       DEFAULT :
  494.       CASE FALSE :
  495.          ENDCASE
  496.       $)
  497.  
  498.       IF fd ~= 0 THEN
  499.       $( endstream(fd)
  500.          fd := 0
  501.       $)
  502.  
  503.    $) REPEAT
  504.    rem.sc.mode(FALSE)
  505.    RESULTIS r
  506. $)
  507.  
  508. AND remote.finish() = VALOF
  509. $( LET num,len = ?,?
  510.    numtry := 0
  511.    n := 0
  512.    packet%0 := 'F'
  513.    $( spack('G',0,1,packet)
  514.       SWITCHON rpack(@len,@num,recpkt) INTO
  515.       $(
  516.       CASE 'Y' :
  517.          IF len ~= 0 THEN message(recpkt,len)
  518.          RESULTIS TRUE
  519.       CASE 'N' :
  520.       CASE FALSE :
  521.          numtry := numtry+1
  522.          IF numtry >= maxtry THEN RESULTIS FALSE
  523.          ENDCASE
  524.       DEFAULT :
  525.          erroring := TRUE
  526.          RESULTIS FALSE
  527.       $)
  528.    $) REPEAT
  529. $)
  530.  
  531. AND show.help() BE
  532. $( writes("C                              - Connect*N")
  533.    writes("E                              - Exit*N")
  534.    writes("FINISH                         - Finish server mode on a *
  535.                                            *remote kermit*N")
  536.    writes("G file1 <file2> <file3> ...    - Get file(s) from a server*N")
  537.    writes("HELP                           - This message*N")
  538.    writes("R                              - Receive file(s)*N")
  539.    writes("S file1 <file2> <file3> ...    - Send file(s)*N")
  540.    writes("SET                            - Set various options*N")
  541.    writes("SERVER                         - Set server mode*N")
  542.    writes("SHOW                           - Show the settable option settings*N")
  543.    writes("STATUS                         - Print information about*N*
  544.           *                                 latest transaction*N")
  545. $)
  546.  
  547. /*
  548.    Do.status
  549.  
  550.       Display status information
  551. */
  552.  
  553. AND printtime(t) BE
  554.    writef("%N:%N:%N",(t!1)/60,(t!1) REM 60,(t!2)/tickspersecond)
  555.  
  556. AND do.status() BE
  557. $( TEST finishtime!0 = -1 THEN
  558.       writes("No valid last transfer*N")
  559.    ELSE
  560.    $( LET t1 = ?
  561.       writef("Last transfer :-*N")
  562.       writef("  Started at        : ") ; printtime(starttime) ; newline()
  563.       writef("  Finished at       : ") ; printtime(finishtime) ; newline()
  564.       writef("Bytes transferred   : %N*N",bytes)
  565.       t1 := (finishtime!0 - starttime!0)
  566.  
  567.       writef("Effective baud rate : %N baud*N",
  568.                               (bytes*bitsperbyte)*tickspersecond/t1)
  569.    $)
  570. $)
  571.  
  572. /*
  573.    Do.show
  574.  
  575.       Show a selection of currently set parameters etc.
  576. */
  577.  
  578. AND do.show() BE
  579. $(
  580.    writef("Escape character       - CTRL-%C*N",escchr+'@')
  581.    writef("Remote delay           - %N seconds*N",remote.delay)
  582.    writef("Image mode             - %S*N",image->"ON","OFF")
  583.    writef("8-bit quote character  - %C*N",quote8)
  584.    writef("Reporting              - %S*N",reporting->"ON","OFF")
  585.    newline()
  586.    writef("Transmission section : -*N")
  587.    writef("  Packet length        - %N*N",s.packet.length)
  588.    writef("  No. of pad chars     - %N*N",s.pad)
  589.    writef("  Pad character        - #X%X2*N",s.padchar)
  590.    writef("  End of line char     - #X%X2*N",s.eol)
  591.    writef("  Start of packet char - #X%X2*N",s.sop)
  592.    writef("  Quote character      - %C*N",s.quote)
  593.    writef("  Timeout              - %N seconds*N",s.timeout)
  594.    newline()
  595.    writef("Reception section : -*N")
  596.    writef("  Packet length        - %N*N",r.packet.length)
  597.    writef("  No. of pad chars     - %N*N",r.pad)
  598.    writef("  Pad character        - #X%X2*N",r.padchar)
  599.    writef("  End of line char     - #X%X2*N",r.eol)
  600.    writef("  Start of packet char - #X%X2*N",r.sop)
  601.    writef("  Quote character      - %C*N",r.quote)
  602.    writef("  Timeout              - %N seconds*N",r.timeout)
  603. $)
  604.  
  605. /*
  606.    Handle the get command
  607. */
  608. AND do.get() = VALOF
  609. $( LET r = ?
  610.    LET len,num = ?,?
  611.  
  612.    bytes := 0
  613.    numtry := 0
  614.    datstamp(starttime)
  615.    filelist := argv
  616.  
  617.    FOR i = 0 TO numfiles-1 DO
  618.    $( filnam := filelist!i
  619.       FOR j = 0 TO filnam%0 -1 DO
  620.          packet%j := filnam%(j+1)
  621.       spack('R',n,filnam%0,packet)
  622.       r := recsw()
  623.       UNLESS r THEN
  624.       $( finishtime!0 := -1
  625.          selectoutput(consout)
  626.          writef("Unable to receive %S*N",filnam)
  627.          RESULTIS FALSE
  628.       $)
  629.    $)
  630.    selectoutput(consout)
  631.    datstamp(finishtime)
  632.    writes("*NOK.*N")
  633.    RESULTIS TRUE
  634. $)
  635.  
  636. /*
  637.    Handle a Send/Receive command
  638.  
  639. */
  640. AND handle.sr() = VALOF
  641. $( LET r = ?
  642.  
  643.    IF remote THEN rem.sc.mode(TRUE)
  644.  
  645.    bytes := 0
  646.    datstamp(starttime)
  647.  
  648.    TEST command = w.s THEN
  649.    $( filelist := argv
  650.       filnam := filelist!0
  651.       r := sendsw()
  652.    $)
  653.    ELSE
  654.    $(
  655.       r := recsw()
  656.    $)
  657.  
  658.    selectoutput(consout)
  659.    TEST r THEN
  660.    $( datstamp(finishtime)
  661.       IF ~remote THEN writef("*NOK.*N")
  662.    $)
  663.    ELSE
  664.    $( IF ~remote THEN
  665.          writef("%S failed.*N",command=w.s->"Send","Receive")
  666.       finishtime!0 := -1
  667.    $)
  668.    IF remote THEN rem.sc.mode(FALSE)
  669.    IF fd ~= 0 THEN
  670.    $( endstream(fd)
  671.       fd := 0
  672.    $)
  673.    RESULTIS FALSE
  674. $)
  675.  
  676. /*
  677.     s e n d s w
  678.  
  679.    Sendsw is the state table switcher for sending
  680.    files. It loops until either it finishes, or
  681.    an error is encountered. The routines called by
  682.    sendsw are responsible for changing the state.
  683. */
  684.  
  685. AND sendsw() = VALOF
  686. $(
  687.    n := 0
  688.    astate := 'S'
  689.    numtry := 0
  690.  
  691.    $( SWITCHON astate INTO
  692.       $(
  693.       CASE 'D' : astate := sdata() ; ENDCASE  /* Data-send state */
  694.       CASE 'F' : astate := sfile() ; ENDCASE  /* File-send */
  695.       CASE 'Z' : astate := seof()  ; ENDCASE  /* End-Of-File */
  696.       CASE 'S' : astate := sinit() ; ENDCASE  /* Send Init */
  697.       CASE 'B' : astate := sbreak(); ENDCASE  /* Break-Send */
  698.       CASE 'C' : RESULTIS TRUE                /* Complete */
  699.       DEFAULT  :                              /* Unknown, fail */
  700.       CASE 'A' : erroring := TRUE
  701.                  RESULTIS FALSE               /* Unknown, fail */
  702.       $)
  703.    $) REPEAT
  704. $)
  705.  
  706. /*
  707.     s i n i t
  708.  
  709.    Send initiate: Send my parameters, get other side's back.
  710.  
  711. */
  712.  
  713. AND sinit() = VALOF
  714. $( LET num,len = ?,?
  715.  
  716.    IF numtry > maxtry THEN
  717.    $( numtry := numtry + 1
  718.       RESULTIS 'A'
  719.    $)
  720.    numtry := numtry + 1
  721.  
  722.    len := spar(packet)
  723.    IF remote & (~serving) THEN delay(remote.delay*tickspersecond)
  724.    spack('S',n,len,packet)
  725.    SWITCHON rpack(@len,@num,recpkt) INTO
  726.    $( CASE 'N' :
  727.          report(FALSE)
  728.          RESULTIS astate              /* Nak */
  729.       CASE 'Y' :                     /* Ack */
  730.       $( report(n=num)
  731.          IF n ~= num RESULTIS astate
  732.          rpar(recpkt,len)
  733.          numtry := 0
  734.          n := (n+1) REM 64
  735.          fd := findinput(filnam)
  736.          IF fd = 0 THEN RESULTIS 'A'
  737.          cons(writef,"Sending file %S*N",filnam)
  738.          selectinput(fd)
  739.          RESULTIS 'F'
  740.       $)
  741.       CASE FALSE :
  742.          report(FALSE)
  743.          RESULTIS astate
  744.       DEFAULT :
  745.          RESULTIS 'A'
  746.    $)
  747. $)
  748.  
  749. /*
  750.     s f i l e
  751.  
  752.    Send File Header
  753.  
  754. */
  755. AND sfile() = VALOF
  756. $( LET num,len = ?,?
  757.    LET name = VEC 20
  758.    wptr := 4
  759.    IF numtry > maxtry THEN
  760.    $( numtry := numtry + 1
  761.       RESULTIS 'A'
  762.    $)
  763.    numtry := numtry + 1
  764.  
  765.    len := filnam%0
  766.    FOR i = 1 TO len DO name%(i-1) := filnam%i
  767.  
  768.    spack('F',n,len,name)
  769.  
  770.    SWITCHON rpack(@len,@num,recpkt) INTO
  771.    $(
  772.    CASE 'N' :                             /* NAK */
  773.       $( num := num = 0 -> 63,num-1
  774.          IF n ~= num THEN
  775.          $( report(FALSE)
  776.             RESULTIS astate
  777.          $)
  778.       $)
  779.    CASE 'Y' :
  780.       $( report(n=num)
  781.          IF n ~= num THEN RESULTIS astate
  782.          numtry := 0
  783.          n := (n+1) REM 64
  784.          size := bufill(packet)
  785.          RESULTIS 'D'
  786.       $)
  787.    CASE FALSE :
  788.       report(FALSE)
  789.       RESULTIS astate
  790.    DEFAULT :
  791.       RESULTIS 'A'
  792.    $)
  793. $)
  794.  
  795. /*
  796.     s d a t a
  797.  
  798.    Send File Data
  799.  
  800. */
  801. AND sdata() = VALOF
  802. $( LET num,len = ?,?
  803.  
  804.    IF numtry > maxtry THEN
  805.    $( numtry := numtry + 1
  806.       RESULTIS 'A'
  807.    $)
  808.    numtry := numtry + 1
  809.  
  810.    spack('D',n,size,packet)
  811.  
  812.    SWITCHON rpack(@len,@num,recpkt) INTO
  813.    $(
  814.    CASE 'N' :                             /* NAK */
  815.       $( num := num = 0 -> 63,num-1
  816.          IF n ~= num THEN
  817.          $( report(FALSE)
  818.             RESULTIS astate
  819.          $)
  820.       $)
  821.    CASE 'Y' :
  822.       $( report(n=num)
  823.          IF n ~= num THEN RESULTIS astate
  824.          numtry := 0
  825.          n := (n+1) REM 64
  826.          size := bufill(packet)
  827.          RESULTIS size = 0 ->'Z','D'
  828.       $)
  829.    CASE FALSE :
  830.       report(FALSE)
  831.       RESULTIS astate
  832.    DEFAULT :
  833.       RESULTIS 'A'
  834.    $)
  835. $)
  836.  
  837. /*
  838.     s e o f
  839.  
  840.    Send End-Of-File
  841.  
  842. */
  843. AND seof() = VALOF
  844. $( LET num,len = ?,?
  845.  
  846.    IF numtry > maxtry THEN
  847.    $( numtry := numtry + 1
  848.       RESULTIS 'A'
  849.    $)
  850.    numtry := numtry + 1
  851.  
  852.    spack('Z',n,0,packet)
  853.  
  854.    SWITCHON rpack(@len,@num,recpkt) INTO
  855.    $(
  856.    CASE 'N' :                             /* NAK */
  857.       $( num := num = 0 -> 63,num-1
  858.          IF n ~= num THEN
  859.          $( report(FALSE)
  860.             RESULTIS astate
  861.          $)
  862.       $)
  863.    CASE 'Y' :
  864.       $( report(n=num)
  865.          IF n ~= num THEN RESULTIS astate
  866.          numtry := 0
  867.          n := (n+1) REM 64
  868.          endread()
  869.          fd := 0
  870.          UNLESS gnxtfl() THEN RESULTIS 'B'
  871.          RESULTIS 'F'
  872.       $)
  873.    CASE FALSE :
  874.       report(FALSE)
  875.       RESULTIS astate
  876.    DEFAULT :
  877.       RESULTIS 'A'
  878.    $)
  879. $)
  880.  
  881. /*
  882.     s b r e a k
  883.  
  884.    Send Break (EOT)
  885.  
  886. */
  887. AND sbreak() = VALOF
  888. $( LET num,len = ?,?
  889.  
  890.    IF numtry > maxtry THEN
  891.    $( numtry := numtry + 1
  892.       RESULTIS 'A'
  893.    $)
  894.    numtry := numtry + 1
  895.  
  896.    spack('B',n,0,packet)
  897.  
  898.    SWITCHON rpack(@len,@num,recpkt) INTO
  899.    $(
  900.    CASE 'N' :                             /* NAK */
  901.       $( num := num = 0 -> 63,num-1
  902.          IF n ~= num THEN
  903.          $( report(FALSE)
  904.             RESULTIS astate
  905.          $)
  906.       $)
  907.    CASE 'Y' :
  908.       $( report(n=num)
  909.          IF n ~= num THEN RESULTIS astate
  910.          numtry := 0
  911.          n := (n+1) REM 64
  912.          RESULTIS 'C'
  913.       $)
  914.    CASE FALSE :
  915.       report(FALSE)
  916.       RESULTIS astate
  917.    DEFAULT :
  918.       RESULTIS 'A'
  919.    $)
  920. $)
  921.  
  922. /*
  923.     r e c s w
  924.  
  925.    This is the state table switcher for receiving files.
  926.  
  927. */
  928.  
  929. AND recsw() = VALOF
  930. $( TEST serving THEN
  931.    $( astate := 'F'
  932.       n := 1
  933.    $)
  934.    ELSE
  935.    $( n := 0
  936.       astate := 'R'
  937.    $)
  938.    numtry := 0
  939.  
  940.    $( SWITCHON astate INTO
  941.       $(
  942.       CASE 'D' : astate := rdata() ; ENDCASE     // Data receive state
  943.       CASE 'F' : astate := rfile() ; ENDCASE     // File receive state
  944.       CASE 'R' : astate := rinit() ; ENDCASE     // Send initiate state
  945.       CASE 'C' : RESULTIS TRUE                   // Complete state
  946.       CASE 'A' : erroring := TRUE
  947.                  RESULTIS FALSE                  // Abort state
  948.       $)
  949.    $) REPEAT
  950. $)
  951.  
  952. /*
  953.     r i n i t
  954.  
  955.    Receive Initialisation
  956.  
  957. */
  958. AND rinit() = VALOF
  959. $( LET len,num = ?,?
  960.  
  961.    IF numtry > maxtry THEN
  962.    $( numtry := numtry + 1
  963.       RESULTIS 'A'
  964.    $)
  965.    numtry := numtry + 1
  966.  
  967.    SWITCHON rpack(@len,@num,packet) INTO
  968.    $(
  969.    CASE 'S' :
  970.       $( rpar(packet,len)
  971.          len := spar(packet)
  972.          report(TRUE)
  973.          spack('Y',n,len,packet)
  974.          oldtry := numtry
  975.          numtry := 0
  976.          n := (n+1) REM 64
  977.          RESULTIS 'F'
  978.       $)
  979.    CASE FALSE :
  980.       report(FALSE)
  981.       RESULTIS astate
  982.    DEFAULT : RESULTIS 'A'
  983.    $)
  984. $)
  985.  
  986. /*
  987.     r f i l e
  988.  
  989.    Receive File Header
  990.  
  991. */
  992.  
  993. AND rfile() = VALOF
  994. $( LET len,num = ?,?
  995.    wptr := 0
  996.    IF numtry > maxtry THEN
  997.    $( numtry := numtry + 1
  998.       RESULTIS 'A'
  999.    $)
  1000.    numtry := numtry + 1
  1001.  
  1002.    SWITCHON rpack(@len,@num,packet) INTO
  1003.    $(
  1004.    CASE 'S' :
  1005.       $( IF oldtry > maxtry THEN
  1006.          $( oldtry := oldtry + 1
  1007.             RESULTIS 'A'
  1008.          $)
  1009.          oldtry := oldtry + 1
  1010.  
  1011.          TEST (num = (n=0 -> 63,n-1)) THEN
  1012.          $( len := spar(packet)
  1013.             report(FALSE)
  1014.             spack('Y',num,len,packet)
  1015.             numtry := 0
  1016.             RESULTIS astate
  1017.          $)
  1018.          ELSE RESULTIS 'A'
  1019.       $)
  1020.    CASE 'Z' :
  1021.       $( IF oldtry > maxtry THEN
  1022.          $( oldtry := oldtry + 1
  1023.             RESULTIS 'A'
  1024.          $)
  1025.          oldtry := oldtry + 1
  1026.  
  1027.          TEST (num = (n=0 -> 63,n-1)) THEN
  1028.          $( spack('Y',num,0,0)
  1029.             report(FALSE)
  1030.             numtry := 0
  1031.             RESULTIS astate
  1032.          $)
  1033.          ELSE RESULTIS 'A'
  1034.       $)
  1035.    CASE 'F' :                          /* File Header */
  1036.       $( IF (num ~= n) RESULTIS 'A'
  1037.          IF ~getfil(packet) THEN RESULTIS 'A'
  1038.          spack('Y',num,0,0)
  1039.          report(TRUE)
  1040.          oldtry := numtry
  1041.          numtry := 0
  1042.          n := (n+1) REM 64
  1043.          RESULTIS 'D'
  1044.       $)
  1045.    CASE 'B' :                          /* Break transmission */
  1046.       $( IF num ~= n THEN RESULTIS 'A'
  1047.          spack('Y',n,0,0)
  1048.          RESULTIS 'C'
  1049.       $)
  1050.    CASE FALSE :
  1051.       report(FALSE)
  1052.       RESULTIS astate
  1053.    DEFAULT : RESULTIS 'A'
  1054.    $)
  1055. $)
  1056.  
  1057. /*
  1058.     r d a t a
  1059.  
  1060.    Receive data
  1061.  
  1062. */
  1063. AND rdata() = VALOF
  1064. $( LET num,len = ?,?
  1065.  
  1066.    IF numtry > maxtry THEN
  1067.    $( numtry := numtry + 1
  1068.       RESULTIS 'A'
  1069.    $)
  1070.    numtry := numtry + 1
  1071.  
  1072.    SWITCHON rpack(@len,@num,packet) INTO
  1073.    $(
  1074.    CASE 'D' :
  1075.       $( TEST num ~= n THEN
  1076.          $( IF oldtry > maxtry THEN
  1077.             $( oldtry := oldtry + 1
  1078.                RESULTIS 'A'
  1079.             $)
  1080.             oldtry := oldtry + 1
  1081.  
  1082.             IF num = (n=0 -> 63,n-1) THEN
  1083.             $( spack('Y',num,6,packet)
  1084.                report(FALSE)
  1085.                numtry := 0
  1086.                RESULTIS astate
  1087.             $)
  1088.             RESULTIS 'A'
  1089.          $)
  1090.          ELSE
  1091.          $( bufemp(packet,fd,len)
  1092.             spack('Y',n,0,0)
  1093.             report(TRUE)
  1094.             oldtry := numtry
  1095.             numtry := 0
  1096.             n := (n+1) REM 64
  1097.             RESULTIS 'D'
  1098.          $)
  1099.       $)
  1100.    CASE 'F' :                    // Got a file header
  1101.       $( IF oldtry > maxtry THEN
  1102.          $( oldtry := oldtry + 1
  1103.             RESULTIS 'A'
  1104.          $)
  1105.          oldtry := oldtry + 1
  1106.  
  1107.          IF num = (n=0 -> 63,n-1) THEN
  1108.          $( spack('Y',num,0,0)
  1109.             report(FALSE)
  1110.             numtry := 0
  1111.             RESULTIS astate
  1112.          $)
  1113.          RESULTIS 'A'
  1114.       $)
  1115.    CASE 'Z' :
  1116.       $( IF num ~= n THEN RESULTIS 'A'
  1117.          spack('Y',n,0,0)
  1118.          report(TRUE)
  1119.          IF image & (wptr ~= 0) THEN writewords(@word,1)
  1120.          endwrite()
  1121.          fd := 0
  1122.          n := (n+1) REM 64
  1123.          RESULTIS 'F'
  1124.       $)
  1125.    CASE FALSE :
  1126.       report(FALSE)
  1127.       RESULTIS astate
  1128.    DEFAULT    : RESULTIS 'A'
  1129.    $)
  1130. $)
  1131.  
  1132. /*
  1133.     c o n n e c t
  1134.  
  1135.    Establish a virtual terminal connection with the remote machine, over
  1136.    the other tty line.
  1137.  
  1138. */
  1139.  
  1140. AND connect.pktwait(dest,p) = cowait(p)
  1141. AND rem.rdch()   =  readchar()
  1142. AND loc.rdch()   =  sendpkt(notinuse,consoletask,act.sc.read, ?,?)
  1143. AND rem.wrch(ch) BE sendpkt(notinuse,remfd,      act.sc.write,?,?,ch)
  1144. AND loc.wrch(ch) BE sendpkt(notinuse,consoletask,act.sc.write,?,?,ch)
  1145.  
  1146. AND co1.rtn() BE              // Local to remote
  1147. $( LET ch = ?
  1148.    $( ch := loc.rdch()
  1149.       IF ch = escchr THEN
  1150.       $( end.connect := TRUE
  1151.          cowait(0)
  1152.       $)
  1153.       rem.wrch(ch)
  1154.    $) REPEAT
  1155. $)
  1156.  
  1157. AND co2.rtn() BE              // Remote to local
  1158. $( LET ch = ?
  1159.  
  1160.    $(
  1161.       IF got.sc.pkt THEN
  1162.       $( ch := sc.read.pkt!pkt.res1
  1163.          qpkt(sc.read.pkt)
  1164.          got.sc.pkt := FALSE
  1165.          loc.wrch(ch)
  1166.       $)
  1167.  
  1168.       // see if there are any messages and shove them out
  1169.       UNTIL message.pkts = 0 DO
  1170.       $(
  1171.          LET p = message.pkts
  1172.          LET msg = p ! pkt.arg1
  1173.          LET size = p ! pkt.arg2
  1174.          LET banner = "*C*NKermit: Message...*C*N"
  1175.          message.pkts := !p
  1176.          UNLESS size = 0 DO
  1177.          $(
  1178.             FOR i = 1 TO banner%0 DO loc.wrch(banner%i)
  1179.             FOR i = 0 TO size-1 DO
  1180.             $(
  1181.                IF msg%i = '*N' THEN loc.wrch('*C')
  1182.                loc.wrch(msg%i)
  1183.             $)
  1184.          $)
  1185.          !p := -1
  1186.          returnpkt(p,TRUE,0)
  1187.       $)
  1188.  
  1189.       cowait(0)
  1190.  
  1191.    $) REPEAT
  1192. $)
  1193.  
  1194. AND connect() BE
  1195. $( LET co1 = createco(co1.rtn,200)
  1196.    LET co2 = createco(co2.rtn,200)
  1197.    LET p1  = ?
  1198.    LET p2  = ?
  1199.    cons(writef,"[Connecting to remote host, type CTRL-%C to return]*N",
  1200.                                                   escchr+'@')
  1201.    loc.sc.mode(TRUE)
  1202.    pktwait := connect.pktwait
  1203.    p1 := callco(co1)
  1204.    p2 := callco(co2)
  1205.    end.connect := FALSE
  1206.    $( LET p = taskwait()
  1207.       TEST p = p1 THEN
  1208.          p1 := callco(co1,p)  // local to remote
  1209.       ELSE
  1210.          TEST p = p2 THEN p2 := callco(co2,p)  // remote to local
  1211.          ELSE
  1212.          $( TEST p = sc.read.pkt THEN got.sc.pkt := TRUE
  1213.             ELSE
  1214.             $( LET qe = @message.pkts
  1215.  
  1216.                UNLESS p!pkt.type = act.sc.msg THEN abort(200)
  1217.  
  1218.                UNTIL !qe=0 DO qe := !qe
  1219.                !qe := p
  1220.                !p  := 0
  1221.             $)
  1222.          $)
  1223.       IF p2=0 & ( got.sc.pkt | message.pkts~=0) THEN p2:=callco(co2)
  1224.       IF end.connect THEN BREAK
  1225.    $) REPEAT
  1226.  
  1227.    pktwait := my.pktwait
  1228.    loc.sc.mode(FALSE)
  1229.    cons(writes,"*N[Back at TRIPOS]*N")
  1230.    deleteco(co1)
  1231.    deleteco(co2)
  1232. $)
  1233.  
  1234. /*
  1235.       KERMIT utilities
  1236. */
  1237.  
  1238. AND clkint() BE
  1239. $(
  1240.    longjump(clk.p,clk.l)
  1241. $)
  1242.  
  1243. /* tochar converts a control character to a printable one by adding a space */
  1244.  
  1245. AND tochar(ch) = ch + '*S'
  1246.  
  1247. /* unchar undoes tochar */
  1248.  
  1249. AND unchar(ch) = ch - '*S'
  1250.  
  1251. /*
  1252.    ctl turns a control character into a printable character by toggling the
  1253.    control bit (ie. ^A -> A and A -> ^A
  1254. */
  1255.  
  1256. AND ctl(ch) = ch NEQV 64
  1257.  
  1258. /*
  1259.     s p a c k
  1260.  
  1261.    Send a packet
  1262. */
  1263. AND spack(type,num,len,data) BE
  1264. $( LET i = ?
  1265.    LET chksum = ?
  1266.    LET buffer = VEC 100/bytesperword
  1267.  
  1268.    FOR i = 1 TO s.pad DO sendchar(s.padchar)
  1269.  
  1270.    buffer%0 := s.sop
  1271.    chksum := tochar(len+3)
  1272.    buffer%1 := tochar(len+3)
  1273.    chksum := chksum+tochar(num)
  1274.    buffer%2 := tochar(num)
  1275.    chksum := chksum+type
  1276.    buffer%3 := type
  1277.  
  1278.    FOR i = 4 TO 4+len-1 DO
  1279.    $( LET d = data%(i-4)
  1280.       buffer%i := d
  1281.       chksum := chksum+d
  1282.    $)
  1283.  
  1284.    chksum := (chksum + ((chksum & #XC0) >> 6)) & #X3F
  1285.    buffer%(4+len) := tochar(chksum)
  1286.    buffer%(5+len) := s.eol
  1287.    sendchars(buffer,5+len)
  1288. $)
  1289.  
  1290. AND sendchar(ch) BE
  1291.    sendpkt(notinuse,remfd,act.sc.write,?,?,ch)
  1292.  
  1293. AND sngl.sc(b,upb) BE
  1294.    FOR i = 0 TO upb DO sendchar(b%i)
  1295.  
  1296. AND multi.sc(b,upb) BE
  1297.    sendpkt(notinuse,remfd,act.sc.write,?,?,b,0,upb+1)
  1298.  
  1299. AND readchar() = VALOF
  1300. $( LET r = ?
  1301.    UNLESS got.sc.pkt THEN pktwait(remfd,sc.read.pkt)
  1302.    r := sc.read.pkt!pkt.res1
  1303.    qpkt(sc.read.pkt)
  1304.    got.sc.pkt := FALSE
  1305.    RESULTIS r
  1306. $)
  1307.  
  1308. /*
  1309.     r p a c k
  1310.  
  1311.    Receive a packet
  1312.  
  1313. */
  1314. AND rpack(len,num,data) = VALOF
  1315. $( LET i,done = ?,?
  1316.    LET chksum,t,type = ?,~SOH,?
  1317.    LET clkpkt = TABLE notinuse,-1,0,?,?,?
  1318.  
  1319.    clk.p := level()
  1320.    clk.l := l1
  1321.    IF ((r.timeout>maxtim) | (r.timeout < mintim)) THEN r.timeout := mytime
  1322.    clkpkt!pkt.arg1 := r.timeout*tickspersecond
  1323.    qpkt(clkpkt)
  1324.  
  1325.    WHILE (t ~= r.sop) DO t := readchar()
  1326.  
  1327.    done := FALSE
  1328.    WHILE ~done DO
  1329.    $( t := readchar()
  1330.       IF ~image THEN t := t & #X7F
  1331.       IF t = r.sop LOOP
  1332.  
  1333.       chksum := t
  1334.       !len := unchar(t)-3
  1335.  
  1336.       t := readchar()
  1337.       IF ~image THEN t := t & #X7F
  1338.       IF t = r.sop LOOP
  1339.       chksum := chksum+t
  1340.       !num := unchar(t)
  1341.  
  1342.       t := readchar()
  1343.       IF ~image THEN t := t & #X7F
  1344.       IF t = r.sop LOOP
  1345.       chksum := chksum+t
  1346.       type := t
  1347.  
  1348.       FOR i = 0 TO (!len)-1 DO
  1349.       $( t := readchar()
  1350.          IF ~image THEN t := t & #X7F
  1351.          IF t = r.sop LOOP
  1352.          chksum := chksum+t
  1353.          data%i := t
  1354.       $)
  1355.       data%(!len) := 0
  1356.  
  1357.       t := readchar()
  1358.       IF ~image THEN t := t & #X7F
  1359.       IF t = r.sop LOOP
  1360.       done := TRUE
  1361.  
  1362.       dqpkt(-1,clkpkt)
  1363.    $)
  1364.    chksum := (chksum + ((chksum & #XC0)>>6)) & #X3F
  1365.    IF chksum ~= unchar(t) RESULTIS FALSE
  1366.    RESULTIS type
  1367. l1: RESULTIS FALSE
  1368. $)
  1369.  
  1370. /*
  1371.    p u t b u f f
  1372.  
  1373.    Put a character in the buffer
  1374.  
  1375.    Control and 8-bit quoting are performed if required/elected
  1376. */
  1377.  
  1378. AND putbuff(buffer,i,ch) = VALOF
  1379. $( LET j = 0
  1380.    LET ch7 = ch & #X7F
  1381.  
  1382.    IF quote8ing THEN              // Do 8-bit quote
  1383.    $( IF (ch & #X80) ~= 0 THEN
  1384.       $( buffer%(i+j) := quote8
  1385.          j := j+1
  1386.       $)
  1387.       ch := ch7
  1388.    $)
  1389.  
  1390.    IF (ch7 < sp) | (ch7 = del) |             // Quote control characters
  1391.       (ch7 = s.quote) |                      // And the funnies
  1392.       ((ch7 = quote8) & quote8ing) THEN
  1393.    $( IF ~image & (ch7 = '*N') THEN
  1394.       $( buffer%(i+j) := s.quote
  1395.          buffer%(i+j+1) := ctl('*C')
  1396.          j := j+2
  1397.       $)
  1398.       buffer%(i+j) := s.quote
  1399.       j := j+1
  1400.       IF (ch7 < sp) | (ch7 = del) THEN ch := ctl(ch)
  1401.    $)
  1402.  
  1403.    buffer%(i+j) := ch
  1404.    j := j+1
  1405.    RESULTIS j
  1406. $)
  1407.  
  1408. /*
  1409.     b u f i l l
  1410.  
  1411.    Get a bufferful of data from the file that's being sent.
  1412.  
  1413. */
  1414.  
  1415. AND image.rdch() = VALOF
  1416. $( LET r = ?
  1417.    IF wptr = 4 THEN
  1418.    $( r := readwords(@word,1)
  1419.       IF r = 0 THEN RESULTIS endstreamch
  1420.       wptr := 0
  1421.    $)
  1422.    r := (@word)%wptr
  1423.    wptr := wptr+1
  1424.    RESULTIS r
  1425. $)
  1426.  
  1427. AND image.unrdch() BE wptr := wptr-1
  1428.  
  1429. AND bufill(buffer) = VALOF
  1430. $( LET i,j = ?,?
  1431.    LET rch = image -> image.rdch,rdch
  1432.    LET unrch = image -> image.unrdch,unrdch
  1433.    LET t = rch()
  1434.  
  1435.    i := 0
  1436.  
  1437.    WHILE t ~= endstreamch DO
  1438.    $( bytes := bytes+1
  1439.       j := putbuff(buffer,i,t)
  1440.       IF i+j > s.packet.length-8 THEN $( unrch() ; RESULTIS i $)
  1441.       i := i+j
  1442.       t := rch()
  1443.    $)
  1444.    RESULTIS i
  1445. $)
  1446.  
  1447. /*
  1448.     b u f e m p
  1449.  
  1450.    Get data from an incoming packet into a file
  1451.  
  1452. */
  1453. AND image.wrch(ch) BE
  1454. $( (@word)%wptr := ch
  1455.    wptr := (wptr + 1) REM 4
  1456.    IF wptr = 0 THEN
  1457.       writewords(@word,1)
  1458. $)
  1459.  
  1460. AND bufemp(buffer,fd,len) BE
  1461. $( LET t = ?
  1462.    LET wch = image-> image.wrch,wrch
  1463.    FOR i = 0 TO len-1 DO
  1464.    $( LET m = 0
  1465.       t := buffer%i
  1466.       IF (t = quote8) & quote8ing THEN
  1467.       $( m := #X80
  1468.          i := i+1
  1469.          t := buffer%i
  1470.       $)
  1471.       IF t = r.quote THEN
  1472.       $( LET t7 = ?
  1473.          i := i+1
  1474.          t := buffer%i
  1475.          t7 := t & #X7F
  1476.          IF (t7 ~= r.quote) &
  1477.             (t7 ~= quote8) THEN
  1478.             t := ctl(t)
  1479.       $)
  1480.       IF image | (t ~= '*C') THEN $( bytes := bytes+1 ; wch(t|m) $)
  1481.    $)
  1482. $)
  1483.  
  1484. /*
  1485.     g e t f i l
  1486.  
  1487.    Open a new file
  1488.  
  1489. */
  1490.  
  1491. AND alphanumeric(ch) = ('A' <= capitalch(ch) <= 'Z') | ('0' <= ch <= '9')
  1492.  
  1493. AND getfil(filenm) = VALOF
  1494. $( LET l = 0
  1495.    UNTIL filenm%l = 0 DO l := l+1
  1496.    FOR i = l TO 1 BY -1 DO filenm%i := filenm%(i-1)
  1497.    filenm%0 := l
  1498.    fd := findoutput(filenm)
  1499.    TEST fd ~= 0 THEN cons(writef,"*NReceiving file %S*N",filenm)
  1500.    ELSE
  1501.    $( FOR i = 1 TO filenm%0 DO
  1502.          IF ~alphanumeric(filenm%i) THEN filenm%i := '-'
  1503.       fd := findoutput(filenm)
  1504.       IF fd ~= 0 THEN cons(writef,"*NReceiving file %S*N",filenm)
  1505.    $)
  1506.    selectoutput(fd)
  1507.    RESULTIS fd ~= 0
  1508. $)
  1509.  
  1510. /*
  1511.     g n x t f l
  1512.  
  1513.    Get next file in a file group
  1514. */
  1515. AND gnxtfl() = VALOF
  1516. $( filecnt := filecnt + 1
  1517.    IF filecnt = numfiles THEN RESULTIS FALSE
  1518.    filnam := filelist!filecnt
  1519.    fd := findinput(filnam)
  1520.    IF fd ~= 0 THEN cons(writef,"*NSending file %S*N",filnam)
  1521.    selectinput(fd)
  1522.    RESULTIS fd ~= 0
  1523. $)
  1524.  
  1525. AND cons(f,a1,a2,a3,a4,a5) BE IF ~remote THEN
  1526. $( LET co = output()
  1527.    selectoutput(consout)
  1528.    f(a1,a2,a3,a4,a5)
  1529.    selectoutput(co)
  1530. $)
  1531.  
  1532. AND report(f) BE IF reporting THEN
  1533. $( TEST f THEN
  1534.    $( pakcnt := (pakcnt+1) REM 5
  1535.       IF pakcnt = 0 THEN
  1536.          cons(writes,".*E")
  1537.    $)
  1538.    ELSE
  1539.       cons(writes,"%*E")
  1540. $)
  1541.  
  1542. AND my.pktwait(dest,pkt) = VALOF
  1543. $(
  1544.    $( LET p = taskwait()
  1545.       IF p = pkt THEN RESULTIS p
  1546.  
  1547.       TEST p = sc.read.pkt THEN got.sc.pkt := TRUE
  1548.       ELSE
  1549.          TEST p!pkt.type = act.sc.msg THEN returnpkt(p)
  1550.          ELSE
  1551.             TEST p!pkt.id = -1 THEN longjump(clk.p,clk.l)
  1552.             ELSE
  1553.             $( abort(100,p)
  1554.                returnpkt(p,FALSE)
  1555.             $)
  1556.    $) REPEAT
  1557. $)
  1558.  
  1559. /*
  1560.     s p a r
  1561.  
  1562.    Fill the data area with the send-init parameters
  1563.  
  1564. */
  1565. AND spar(data) = VALOF
  1566. $( data%0 := tochar(r.packet.length)
  1567.    data%1 := tochar(s.timeout)
  1568.    data%2 := tochar(r.pad)
  1569.    data%3 := ctl(r.padchar)
  1570.    data%4 := tochar(r.eol)
  1571.    data%5 := s.quote
  1572.    data%6 := command = w.s -> 'Y', quote8ing -> quote8,'*S'
  1573.    RESULTIS 7
  1574. $)
  1575.  
  1576. /*
  1577.     r p a r
  1578.  
  1579.    Get the remote's send-init parameters
  1580.  
  1581. */
  1582.  
  1583. AND rpar(data,len) BE
  1584. $( LET v = ?
  1585.    s.packet.length := maxpack
  1586.    r.timeout := mytime
  1587.    s.eol := myeol
  1588.    s.quote := myquote
  1589.    s.pad := mypad
  1590.    s.padchar := mypchar
  1591.    quote8ing := FALSE
  1592.  
  1593.    SWITCHON len INTO
  1594.    $(
  1595.    DEFAULT :
  1596.    CASE 8:
  1597.    CASE 7 :                      // 8-bit
  1598.       SWITCHON data%6 INTO
  1599.       $(
  1600.       CASE 'N' : quote8ing := FALSE
  1601.                  ENDCASE
  1602.       DEFAULT  : quote8 := data%6
  1603.       CASE 'Y' : quote8ing := TRUE
  1604.                  ENDCASE
  1605.       $)
  1606.    CASE 6 :                      // quote character
  1607.       UNLESS data%5 = '*S' THEN
  1608.          r.quote := data%5
  1609.    CASE 5 :                      // eol character
  1610.       UNLESS data%4 = '*S' THEN
  1611.          s.eol := unchar(data%4)
  1612.    CASE 4 :                      // pad character
  1613.       UNLESS data%3 = '*S' THEN
  1614.         s.padchar := ctl(data%3)
  1615.    CASE 3 :                      // no. of pad characters
  1616.       UNLESS data%2 = '*S' THEN
  1617.          s.pad := unchar(data%2)
  1618.    CASE 2 :                      // timeout
  1619.       UNLESS data%1 = '*S' THEN
  1620.          r.timeout := unchar(data%1)
  1621.    CASE 1 :                      // packet length
  1622.       UNLESS data%0 = '*S' THEN
  1623.          s.packet.length := unchar(data%0)
  1624.    CASE 0 :
  1625.    $)
  1626. $)
  1627.  
  1628. /*
  1629.     p a r s e r
  1630.  
  1631.    The command parser to is based on the table driven
  1632.   parser by CGS.
  1633. */
  1634.  
  1635. /*
  1636.    The action routines
  1637. */
  1638.  
  1639. AND parm.vec(buff,buffs,buffl,val,id) = VALOF // Set the parameter vector
  1640. $( parse.vec := id                            // we are to play with
  1641.    RESULTIS TRUE
  1642. $)
  1643.  
  1644. AND set.p(buff,buffs,buffl,val,id) = VALOF    // Change a parameter
  1645. $( parse.vec!id := val                        // in the current vector
  1646.    RESULTIS TRUE
  1647. $)
  1648.  
  1649. AND commandtype(buff,buffs,buffl,val,id) = VALOF   // Store the command word
  1650. $( command := id
  1651.    RESULTIS TRUE
  1652. $)
  1653.  
  1654. AND set.delay(buff,buffs,buffl,val,id) = VALOF     // Host delay
  1655. $( remote.delay := val
  1656.    RESULTIS TRUE
  1657. $)
  1658.  
  1659. AND set.image(buff,buffs,buffl,val,id) = VALOF     // Image flag
  1660. $( image := id
  1661.    RESULTIS TRUE
  1662. $)
  1663.  
  1664. AND set.reporting(buff,buffs,buffl,val,id) = VALOF // Reporting flag
  1665. $( reporting := id
  1666.    RESULTIS TRUE
  1667. $)
  1668.  
  1669. AND set.escchr(buff,buffs,buffl,val,id) = VALOF    // Escape character
  1670. $( IF val < '*S' THEN
  1671.    $( escchr := val
  1672.       RESULTIS TRUE
  1673.    $)
  1674.    RESULTIS FALSE
  1675. $)
  1676.  
  1677. AND set.quote8(buff,buffs,buffl,val,id) = VALOF    // 8-bit quote character
  1678. $( quote8 := val
  1679.    RESULTIS TRUE
  1680. $)
  1681.  
  1682. AND setfile(buff,buffs,buffl,val,id) = VALOF      // Remember file name
  1683. $( LET p = argv+argvp
  1684.    argvp := argvp+buffl/bytesperword+1
  1685.    IF argvp > argvl THEN RESULTIS FALSE
  1686.    p%0 := buffl
  1687.    FOR i = 0 TO buffl-1 DO
  1688.       p%(i+1) := buff%(buffs+i)
  1689.    argv!numfiles := p
  1690.    numfiles := numfiles+1
  1691.    RESULTIS TRUE
  1692. $)
  1693.  
  1694. AND blank(buff,buffs,buffl,val,id,flg) = VALOF
  1695. $( !flg := id -> !flg | f.bsupp, !flg & (~f.bsupp)
  1696.    RESULTIS TRUE
  1697. $)
  1698.  
  1699. AND copyvec(b1,b2,u) BE
  1700.    FOR i = 0 TO u DO b2!i := b1!i
  1701.  
  1702. AND copystring(s1,s2) BE
  1703.    FOR i = 0 TO s1%0 DO s2%i := s1%i
  1704.  
  1705. AND change.setname(name) = VALOF
  1706. $(
  1707.       LET newdir = currentdir
  1708.       LET setname = name
  1709.       LET clilen = my.setname%0
  1710.       LET dir = ?
  1711.       IF compstring(setname,".")=0 THEN  // request to set to previous dir
  1712.       $( for i=clilen to 1 by -1 do      // look for '.' or ':'
  1713.          $( if my.setname%i='.' then
  1714.             $( clilen := i-1
  1715.                break
  1716.             $)
  1717.             if my.setname%i=':' then
  1718.             $( clilen := i
  1719.                break
  1720.             $)
  1721.          $)
  1722.          my.setname%0 := clilen
  1723.          setname := my.setname
  1724.       $)
  1725.       dir := locatedir(setname)
  1726.       TEST dir=0 THEN RESULTIS 0
  1727.       ELSE
  1728.       $( // A new directory. Set it and remember the name
  1729.          let prefix = VEC 4
  1730.          let p = splitname(prefix, ':', setname, 0)
  1731.          TEST p=0 THEN  // No ':'
  1732.          UNLESS my.setname%clilen=':' do  // not if just eg 'sys:'
  1733.          $( clilen := clilen+1
  1734.             my.setname%clilen := '.'
  1735.          $)
  1736.          ELSE
  1737.          $( TEST p=2 then  // just ':', so leave device part alone
  1738.             $( p := splitname(prefix, ':', my.setname, 0)
  1739.                clilen := p-2
  1740.             $)
  1741.             ELSE clilen := 0
  1742.          $)
  1743.          // concatenate name
  1744.          for i=1 to setname%0 do
  1745.             my.setname%(i+clilen) := setname%i
  1746.          my.setname%0 := clilen + setname%0
  1747.          newdir := dir
  1748.       $)
  1749.       RESULTIS newdir
  1750. $)
  1751.  
  1752. /*
  1753.    Initialise the state transition table
  1754. */
  1755.  
  1756. AND init.state.table() BE
  1757. $( istat(1000)
  1758.  
  1759.    state(s1)   ; state(s2)   ; state(s3)   ; state(s4)   ; state(s5)
  1760.    state(s6)   ; state(s7)   ; state(s8)   ; state(s9)   ; state(sa)
  1761.    state(sb)   ; state(sc)   ; state(sd)   ; state(s10)  ; state(s10a)
  1762.    state(s31)  ; state(s11)  ; state(s11a)
  1763.    state(s51)  ; state(s52)  ; state(s53)
  1764.    state(s531) ; state(s532) ; state(s533) ; state(s534) ; state(s535)
  1765.    state(s536) ; state(s537) ; state(s538)
  1766.    state(s5a)  ; state(s5b)  ; state(s53a) ; state(s53b) ; state(s54)
  1767.    state(s55)  ; state(s56)
  1768.    state(sc1)
  1769.    state(sd1)
  1770.    state(term)
  1771.    state(file) ; state(f1)   ; state(f2)   ; state(f3)   ; state(f4)
  1772.    state(f5)   ; state(f6)   ; state(f7)   ; state(f8)   ; state(dirname)
  1773.    state(anychs)
  1774.  
  1775.    trans(s1,s2,it.key,  "C",     0,?)
  1776.    trans(s1,s3,it.key,  "S",     0,?)
  1777.    trans(s1,s4,it.key,  "R",     0,?)
  1778.    trans(s1,s5a,it.key, "SET",   0,?)
  1779.    trans(s1,s10,it.key, "SETDIR",0,?)
  1780.    trans(s1,s11,it.key, "DO"    ,0,?)
  1781.    trans(s1,s6,it.key,  "STATUS",0,?)
  1782.    trans(s1,s7,it.key,  "E",     0,?)
  1783.    trans(s1,s7,it.key,  "EXIT",  0,?)
  1784.    trans(s1,s7,it.key,  "Q",     0,?)
  1785.    trans(s1,s7,it.key,  "QUIT",  0,?)
  1786.    trans(s1,s8,it.key,  "HELP",  0,?)
  1787.    trans(s1,exit.state, it.eos,  ?,commandtype,w.endstream)
  1788.    trans(s1,s9,it.key,  "SHOW",  0,?)
  1789.    trans(s1,sa,it.key,  "SERVER",0,?)
  1790.    trans(s1,sb,it.key,  "FINISH",0,?)
  1791.    trans(s1,sc,it.key,  "G"     ,0,?)
  1792.    trans(s1,sd,it.key,  "TAKE"  ,0,?)
  1793.    trans(s1,exit.state,it.subxp,term,0,?)
  1794.  
  1795.    trans(s2,exit.state,it.subxp,term,commandtype,w.c)
  1796.  
  1797.    trans(s3,s31,it.subxp,file, setfile,?)
  1798.    trans(s31,s31,it.subxp,file, setfile,?)
  1799.    trans(s31,exit.state,it.subxp,term,commandtype,w.s)
  1800.  
  1801.    trans(s4,exit.state,it.subxp,term,commandtype,w.r)
  1802.  
  1803.    trans(s5a,s5b,it.subxp,s5,0,?)
  1804.    trans(s5b,s5b,it.subxp,s5,0,?)
  1805.    trans(s5b,exit.state,it.subxp,term,0,?)
  1806.  
  1807.    trans(s5,s51,it.key,"DELAY",0,?)
  1808.    trans(s5,s52,it.key,"ESCCHR",0,?)
  1809.    trans(s5,s54,it.key,"IMAGE",0,?)
  1810.    trans(s5,s53a,it.key,"RECEIVE",parm.vec,@r.packet.length)
  1811.    trans(s5,s53a,it.key,"SEND",parm.vec,@s.packet.length)
  1812.    trans(s5,s55,it.key,"QUOTE8",0,?)
  1813.    trans(s5,s56,it.key,"REPORT",0,?)
  1814.  
  1815.    trans(s51,exit.state,it.dnumb,?,set.delay,?)
  1816.    trans(s52,exit.state,it.dnumb,?,set.escchr,?)
  1817.  
  1818.    trans(s53a,s53b,it.subxp,s53,0,?)
  1819.    trans(s53b,s53b,it.subxp,s53,0,?)
  1820.    trans(s53b,exit.state,it.lamda,?,0,?)
  1821.  
  1822.    trans(s53,s531,it.key,"EOL",0,?)
  1823.    trans(s53,s532,it.key,"PLEN",0,?)
  1824.    trans(s53,s533,it.key,"PAD",0,?)
  1825.    trans(s53,s534,it.key,"PADCHAR",0,?)
  1826.    trans(s53,s535,it.key,"QUOTE",0,?)
  1827.    trans(s53,s536,it.key,"SOP",0,?)
  1828.    trans(s53,s537,it.key,"TIMEOUT",0,?)
  1829.  
  1830.    trans(s531,exit.state,it.numbr,?,set.p,p.eol)
  1831.    trans(s532,exit.state,it.numbr,?,set.p,p.plen)
  1832.    trans(s533,exit.state,it.numbr,?,set.p,p.pad)
  1833.    trans(s534,exit.state,it.numbr,?,set.p,p.padchar)
  1834.    trans(s535,exit.state,it.numbr,?,set.p,p.quote)
  1835.    trans(s536,exit.state,it.numbr,?,set.p,p.sop)
  1836.    trans(s537,exit.state,it.numbr,?,set.p,p.timeout)
  1837.  
  1838.    trans(s54,exit.state,it.key,"ON",set.image,TRUE)
  1839.    trans(s54,exit.state,it.key,"OFF",set.image,FALSE)
  1840.  
  1841.    trans(s55,exit.state,it.numbr,?,set.quote8,?)
  1842.  
  1843.    trans(s56,exit.state,it.key,"ON",set.reporting,TRUE)
  1844.    trans(s56,exit.state,it.key,"OFF",set.reporting,FALSE)
  1845.  
  1846.    trans(s6,exit.state,it.subxp,term,commandtype,w.status)
  1847.  
  1848.    trans(s7,exit.state,it.subxp,term,commandtype,w.e)
  1849.  
  1850.    trans(s8,exit.state,it.subxp,term,commandtype,w.help)
  1851.  
  1852.    trans(s9,exit.state,it.subxp,term,commandtype,w.show)
  1853.  
  1854.    trans(sa,exit.state,it.subxp,term,commandtype,w.server)
  1855.  
  1856.    trans(sb,exit.state,it.subxp,term,commandtype,w.finish)
  1857.  
  1858.    trans(sc,sc1,it.subxp,file, setfile,?)
  1859.    trans(sc1,sc1,it.subxp,file, setfile,?)
  1860.    trans(sc1,exit.state,it.subxp,term,commandtype,w.get)
  1861.  
  1862.    trans(sd,sd1,it.subxp,file,setfile,?)
  1863.    trans(sd1,exit.state,it.subxp,term,commandtype,w.take)
  1864.  
  1865.    trans(s10,s10a,it.subxp,dirname,setfile,?)
  1866.    trans(s10,exit.state,it.subxp,term,commandtype,w.setdir2)
  1867.    trans(s10a,exit.state,it.subxp,term,commandtype,w.setdir)
  1868.  
  1869.    trans(s11,s11a,it.subxp,anychs,setfile,?)
  1870.    trans(s11a,exit.state,it.subxp,term,commandtype,w.do)
  1871.  
  1872.    trans(term,exit.state,it.eol,?,0,?)
  1873.    trans(term,exit.state,it.char,'*E',0,?)
  1874.    trans(term,exit.state,it.eos,?,0,?)
  1875.  
  1876.    trans(file  , exit.state, it.subxp, f4          , blank     , TRUE     )
  1877.  
  1878.    trans(f4    , f1        , it.strng, ?           , blank     , FALSE    )
  1879.    trans(f4    , f2        , it.char , ':'         , blank     , FALSE    )
  1880.    trans(f4    , f3        , it.char , '-'         , blank     , FALSE    )
  1881.  
  1882.    trans(f1    , f2        , it.char , ':'         , 0         , ?        )
  1883.    trans(f1    , f3        , it.lamda, ?           , 0         , ?        )
  1884.  
  1885.    trans(f2    , f3        , it.strng, ?           , 0         , ?        )
  1886.    trans(f2    , f3        , it.char , '-'         , 0         , ?        )
  1887.  
  1888.    trans(f3    , f2        , it.char , '.'         , 0         , ?        )
  1889.    trans(f3    , f3        , it.char , '-'         , 0         , ?        )
  1890.    trans(f3    , f3        , it.strng, ?           , 0         , ?        )
  1891.    trans(f3    , exit.state, it.lamda, ?           , 0         , ?        )
  1892.  
  1893.    trans(dirname,exit.state, it.subxp, f5          , blank     , TRUE     )
  1894.  
  1895.    trans(f5    , f6        , it.strng, ?           , blank     , FALSE    )
  1896.    trans(f5    , f7        , it.char , ':'         , blank     , FALSE    )
  1897.    trans(f5    , f8        , it.char , '-'         , blank     , FALSE    )
  1898.    trans(f5    , exit.state, it.char , '.'         , 0         , ?        )
  1899.  
  1900.    trans(f6    , f7        , it.char , ':'         , 0         , ?        )
  1901.    trans(f6    , f8        , it.lamda, ?           , 0         , ?        )
  1902.  
  1903.    trans(f7    , f8        , it.strng, ?           , 0         , ?        )
  1904.    trans(f7    , f8        , it.char , '-'         , 0         , ?        )
  1905.    trans(f7    , exit.state, it.lamda, ?           , 0         , ?        )
  1906.  
  1907.    trans(f8    , f2        , it.char , '.'         , 0         , ?        )
  1908.    trans(f8    , f3        , it.char , '-'         , 0         , ?        )
  1909.    trans(f8    , f3        , it.strng, ?           , 0         , ?        )
  1910.    trans(f8    , exit.state, it.lamda, ?           , 0         , ?        )
  1911.  
  1912.    trans(anychs, anychs    , it.any  , ?           , 0         , ?        )
  1913.    trans(anychs, exit.state, it.lamda, ?           , 0         , ?        )
  1914. $)
  1915.  
  1916. AND debug.rtn(f,t) BE RETURN
  1917.  
  1918. AND parse.rdch() = VALOF
  1919. $( LET r = ?
  1920.    IF cptr > cbuf%0 THEN RESULTIS endstreamch
  1921.    r := cbuf%cptr
  1922.    cptr := cptr+1
  1923.    RESULTIS r
  1924. $)
  1925.  
  1926. AND do.parse() = VALOF
  1927. $( LET c.delay = remote.delay
  1928.    LET c.escchr = escchr
  1929.    LET c.r = VEC p.upb
  1930.    LET c.s = VEC p.upb
  1931.    LET c.image = image
  1932.    LET c.rep = reporting
  1933.    LET r1 = ?
  1934.  
  1935.    copyvec(@r.packet.length,c.r,p.upb)
  1936.    copyvec(@s.packet.length,c.s,p.upb)
  1937.    FOR i = 0 TO maxfiles-1 DO argv!i := 0
  1938.    numfiles := 0
  1939.    argvp := maxfiles
  1940.  
  1941.    r1 := parse(s1,parse.rdch,f.bsupp,debug.rtn)
  1942.  
  1943.    UNLESS r1 DO
  1944.    $( remote.delay := c.delay
  1945.       escchr := c.escchr
  1946.       copyvec(c.r,@r.packet.length,p.upb)
  1947.       copyvec(c.s,@s.packet.length,p.upb)
  1948.       image := c.image
  1949.       reporting := c.rep
  1950.    $)
  1951.    RESULTIS r1
  1952. $)
  1953.  
  1954. AND readline(b) BE
  1955. $( LET l = 0
  1956.    LET ch = ?
  1957.  
  1958.    $( ch := rdch()
  1959.       IF ch = endstreamch THEN BREAK
  1960.       $( l := l+1
  1961.          b%l := ch
  1962.       $)
  1963.    $) REPEATUNTIL (ch = '*N') | (ch = '*E')
  1964.    b%0 := l
  1965. $)
  1966.  
  1967. AND findcoh() = VALOF
  1968. $( LET ttab = rtn.tasktab ! rootnode
  1969.    LET csegl = tcb.seglist ! (ttab ! task.consolehandler)
  1970.    LET task = 0
  1971.    LET mine = consoletask
  1972.    MANIFEST $( cg = ug ; in.id = cg+4 ; out.id = cg+5 $)
  1973.  
  1974.    $( FOR j = 1 TO ttab ! 0 DO
  1975.       $( LET ttcb = ttab!j
  1976.          LET segl = ?
  1977.          IF ttcb = 0 LOOP
  1978.          segl := tcb.seglist ! ttcb
  1979.          IF (segl ! 3 = csegl ! 3) & (j ~= mine) &
  1980.             (ttcb!tcb.gbase!in.id < 0) THEN
  1981.          $( task := j
  1982.             BREAK
  1983.          $)
  1984.       $)
  1985.    $)
  1986.    RESULTIS task
  1987. $)
  1988.  
  1989. /*
  1990.    Find a multilink console handler
  1991. */
  1992.  
  1993. AND findml(stname) = VALOF
  1994. $(
  1995.    LET newcoh = ?
  1996.    LET coh = rootnode!rtn.tasktab!consoletask
  1997.    LET mlink = devicetask("MLINK:")
  1998.    LET r = ?
  1999.  
  2000.    IF mlink = 0 THEN
  2001.    $( writes("Can't find multilink*N")
  2002.       RESULTIS 0
  2003.    $)
  2004.  
  2005.    r := sendpkt(notinuse,mlink,act.connect,?,?,stname)
  2006.    IF r = 0 THEN RESULTIS 0
  2007.    sendpkt(notinuse,r,act.sc.mode,?,?,TRUE)
  2008.    RESULTIS r
  2009. $)
  2010.  
  2011. AND closetty() BE IF local
  2012.    rem.sc.mode(FALSE)
  2013.  
  2014. AND closeml() BE IF local
  2015. $( LET mlink = devicetask("MLINK:")
  2016.    sendpkt(notinuse,mlink,act.disconnect)
  2017. $)
  2018.  
  2019. AND rem.sc.mode(m) BE sendpkt(notinuse,remfd,act.sc.mode,?,?,m)
  2020. AND loc.sc.mode(m) BE sendpkt(notinuse,consoletask,act.sc.mode,?,?,m)
  2021. AND message(m,n) BE FOR i = 0 TO n-1 DO wrch(m%i)
  2022.  
  2023. ********************************************************************************
  2024.  
  2025.  
  2026. // This file is the second (and last) TRIPOS Kermit source file
  2027. //
  2028. //
  2029. // Header for TRIPOS CLI and some commands.
  2030. //    (e.g. C, SPOOL, STACK, etc.)
  2031.  
  2032. MANIFEST
  2033. $(
  2034. return.severe  =  20
  2035. return.hard    =  10
  2036. return.soft    =   5
  2037. return.ok      =   0
  2038. flag.break     =   1
  2039. flag.commbreak =   2
  2040. cli.module.gn        =  149
  2041. cli.initialstack     =  1000
  2042. cli.initialfaillevel = return.hard
  2043. $)
  2044.  
  2045. GLOBAL
  2046. $(
  2047. cli.init:          133
  2048. cli.result2:       134
  2049. cli.setname:       135
  2050. cli.commanddir:    136
  2051. cli.returncode:    137
  2052. cli.commandname:   138
  2053. cli.faillevel:     139
  2054. cli.prompt:        140
  2055. cli.standardinput: 141
  2056. cli.currentinput:  142
  2057. cli.commandfile:   143
  2058. cli.interactive:   144
  2059. cli.background:    145
  2060. cli.currentoutput: 146
  2061. cli.defaultstack:  147
  2062. cli.standardoutput:148
  2063. cli.module:        149
  2064. $)
  2065. ---------------------------------------- sys:g.iohdr
  2066. /***********************************************************************
  2067. **             (C) Copyright 1980  TRIPOS Research Group              **
  2068. **            University of Cambridge Computer Laboratory             **
  2069. ************************************************************************
  2070.  
  2071.             ########   ######   ##    ##  ######    #######
  2072.             ########  ########  ##    ##  #######   ########
  2073.                ##     ##    ##  ##    ##  ##    ##  ##    ##
  2074.                ##     ##    ##  ########  ##    ##  ########
  2075.                ##     ##    ##  ##    ##  ##    ##  #######
  2076.                ##     ##    ##  ##    ##  ##    ##  ##  ##
  2077.             ########  ########  ##    ##  #######   ##   ##
  2078.             ########   ######   ##    ##  ######    ##    ##
  2079.  
  2080. ************************************************************************
  2081. **                                                                    **
  2082. ***********************************************************************/
  2083.  
  2084.  
  2085. || TRIPOS Input/Output header.
  2086.  
  2087.  
  2088. MANIFEST
  2089. $( || General actions.
  2090.    Act.Dummy      =1000
  2091.    Act.Read       =1001
  2092.    Act.Write      =1002
  2093.    Act.Seek       =1008
  2094.    Act.EndInput   =1003
  2095.    Act.EndOutput  =1004
  2096.    Act.Findinput  =1005
  2097.    Act.Findoutput =1006
  2098.    Act.End        =1007
  2099.    Act.Writetrack =1009
  2100.    Act.Readtrack  =1010
  2101.    Act.Print      =1011
  2102.    Act.Abortp     =1012
  2103.  
  2104.    Act.Format     =1020
  2105.    Act.Tape       =1021
  2106.  
  2107.    // VDU handling
  2108.    Act.Vdu        = 992
  2109.    Act.SetVdu     = 993
  2110.  
  2111.    // Single character I/O through terminal handlers
  2112.  
  2113.    Act.sc.mode    = 994
  2114.    Act.sc.read    = 995
  2115.    Act.sc.write   = 996
  2116.    Act.sc.msg     = 997
  2117.    act.self.immolation = 998
  2118.    // Console interface to driver
  2119.    act.ttyin      = 999
  2120.    act.ttyout     = 1000
  2121.  
  2122.    || Mag tape
  2123.    act.offline    =1007
  2124.    act.wreof      =1008
  2125.    act.spacefw    =1009
  2126.    act.spacerv    =1010
  2127.    act.wreig      =1011
  2128.    act.rewind     =1012
  2129.  
  2130.  
  2131.    || Device packet offset manifests.
  2132.    || Common:
  2133.    Pkt.Action     =Pkt.Type
  2134.    Pkt.Status     =Pkt.Res1
  2135.    Pkt.Status2    =Pkt.Res2
  2136.    || Timer:
  2137.    Pkt.Time1      =Pkt.Res1
  2138.    Pkt.Time2      =Pkt.Res2
  2139.    Pkt.Delay      =Pkt.Arg1
  2140.    || Disc & MT drivers:
  2141.    Pkt.BuffAddr   =Pkt.Arg1
  2142.    Pkt.WordCount  =Pkt.Arg2
  2143.    Pkt.Drive      =Pkt.Arg3
  2144.    Pkt.Unit       =Pkt.Drive
  2145.    Pkt.Cylinder   =Pkt.Arg4
  2146.    Pkt.Surface    =Pkt.Arg5
  2147.    Pkt.Sector     =Pkt.Arg6
  2148.  
  2149.    || Stream control block.
  2150.    Id.InScb       =['S'<<BitsPerByte]+'I'
  2151.    Id.OutScb      =['S'<<BitsPerByte]+'O'
  2152.    Scb.Link       =0
  2153.    Scb.Id         =1
  2154.    Scb.Type       =2
  2155.    Scb.Buf        =3
  2156.    Scb.Pos        =4
  2157.    Scb.End        =5
  2158.    Scb.Funcs      =6
  2159.    Scb.Func1      =6
  2160.    Scb.Rdch       = Scb.Func1
  2161.    Scb.Func2      =7
  2162.    Scb.Wrch       = Scb.Func2
  2163.    Scb.Func3      =8
  2164.    Scb.Args       =9
  2165.    Scb.Arg1       =9
  2166.    Scb.Arg2       =10
  2167.    Scb.NFunc      =Scb.Args-Scb.Funcs
  2168.    Scb.Upb        =10
  2169.  
  2170.    // Load format types
  2171.    t.hunk         =1000
  2172.    t.reloc        =1001
  2173.    t.end          =1002
  2174.    t.abshunk      =1003
  2175.    t.absreloc     =1004
  2176.    t.ext          =1005
  2177.    t.block        =1006
  2178.    t.table        =1008
  2179.    t.lkedext      =1009
  2180.    t.overlay      =1010
  2181.    t.break        =1011
  2182.  
  2183.    // External reference record types
  2184.    ext.defrel     =1
  2185.    ext.defabs     =2
  2186.    ext.ref        =129
  2187.    ext.common     =130
  2188.  
  2189.    // Error codes
  2190.    err.badbinary        = 121
  2191.    err.badres           = 122
  2192.  
  2193.    // Offsets in overlay supervisor
  2194.  
  2195.    ovsup.id             =   1 + 1
  2196.    ovsup.stream         =   2 + 1
  2197.    ovsup.ovtab          =   3 + 1
  2198.    ovsup.htab           =   4 + 1
  2199.    ovsup.glbvec         =   5 + 1
  2200.  
  2201.    // Overlay supervisor ID words
  2202.  
  2203.    id.word              = #XABCD
  2204.  
  2205.    // Assignment vectors
  2206.    ass.link       = 0
  2207.    ass.task       = 1
  2208.    ass.dir        = 2
  2209.  
  2210.    ass.type       = 3
  2211.    ass.dev        = 4
  2212.    ass.name       = 5
  2213.  
  2214.    // Device types
  2215.  
  2216.    dt.disc        = 1
  2217.    dt.bytestream  = 2
  2218.    dt.virtual     = 3
  2219. $)
  2220. ---------------------------------------- sys:g.libhdr
  2221. // Standard BCPL header for TRIPOS on the MC68000
  2222.  
  2223. GLOBAL
  2224. $(
  2225.      globsize       :   0
  2226.      start          :   1  //        start(pkt)
  2227.      stop           :   2  //        stop(code)
  2228. //  3-9 are machine-dependent.
  2229.      multiply       :   3  // res := multiply(x, y)
  2230.      divide         :   4  // res := divide(x, y)
  2231.      remainder      :   5  // res := remainder(x, y)
  2232.      settime        :   6  // settime()
  2233.      restoretime    :   7  // res := restoretime()
  2234.      gbytes         :   8  // res := Gbytes(ba, size)
  2235.      pbytes         :   9  //        pbytes(ba, size, word)
  2236.      result2        :  10
  2237.      returncode     :  11
  2238.      stackbase      :  12
  2239.      tcb            :  13
  2240.      taskid         :  14
  2241.      getbyte        :  15  // ch  := getbyte(v, i)
  2242.      byteget        :  15  // ch  := byteget(v, i)     [= GETBYTE on 68000]
  2243.      putbyte        :  16  //        putbyte(v, i, ch)
  2244.      byteput        :  16  //        byteput(v, i, ch) [= PUTBYTE on 68000]
  2245.      level          :  17  // p   := level()
  2246.      longjump       :  18  //        longjump(p, l)
  2247.      muldiv         :  19  // res := muldiv(a, b, c)
  2248.      aptovec        :  20  // res := aptovec(fn, upb)
  2249.      sardch         :  21  // ch  := sardch()
  2250.      sawrch         :  22  //        sawrch(ch)
  2251.      createco       :  23  // co  := createco(fn, stsize)
  2252.      deleteco       :  24  //        deleteco(co)
  2253.      callco         :  25  // arg := callco(co, arg)
  2254.      cowait         :  26  // arg := cowait(arg)
  2255.      resumeco       :  27  // arg := resumeco(co, arg)
  2256.      globin         :  28  // res := globin(seg)
  2257.      GetVec         :  29  // v   := getvec(upb)
  2258.      FreeVec        :  30  //        freevec(v)
  2259.      createdev      :  31  // id  := createdev(dcb)
  2260.      deletedev      :  32  // dcb := deletedev(id)
  2261.      createtask     :  33  // id  := createtask(seglist, stsize, pri)
  2262.      deletetask     :  34  // res := deletetask(id)
  2263.      changepri      :  35  // res := changepri(id, pri)
  2264.      setflags       :  36  // res := setflags(id, flags)
  2265.      testflags      :  37  // res := testflags(flags)
  2266.      abort          :  38  //        abort(code, arg)
  2267.      hold           :  39  // res := hold(id)
  2268.      release        :  40  // res := release(id)
  2269.      taskwait       :  41  // pkt := taskwait()
  2270.      qpkt           :  42  // res := qpkt(pkt)
  2271.      dqpkt          :  43  // res := dqpkt(id, pkt)
  2272.      packstring     :  44  // res := packstring(v, s)
  2273.      unpackstring   :  45  //        unpackstring(s, v)
  2274.      endtask        :  46  //        endtask(seg)
  2275.      delay          :  47  // res := delay(ticks)
  2276.      sendpkt        :  48  // res := sendpkt(link,id,type,r1,r2,..,args)
  2277.      returnpkt      :  49  // res := returnpkt(pkt, res1, res2)
  2278.      initio         :  50  //        initio()
  2279.      currentdir     :  51
  2280.      cis            :  52
  2281.      cos            :  53
  2282.      rdch           :  54  // ch  := rdch()
  2283.      unrdch         :  55  // res := unrdch()
  2284.      wrch           :  56  //        wrch(ch)
  2285.      readwords      :  57  // res := readwords(scb, v, n)
  2286.      writewords     :  58  //        writewords(scb, v, n)
  2287.      findinput      :  59  // scb := findinput(name)
  2288.      findoutput     :  60  // scb := findoutput(name)
  2289.      selectinput    :  61  //        selectinput(scb)
  2290.      selectoutput   :  62  //        selectoutput(scb)
  2291.      endread        :  63  //        endread()
  2292.      endwrite       :  64  //        endwrite()
  2293.      input          :  65  // scb := input()
  2294.      output         :  66  // scb := output()
  2295.      readn          :  67  // n   := readn()
  2296.      newline        :  68  //        newline()
  2297.      writed         :  69  //        writed(n, d)
  2298.      writen         :  70  //        writen(n)
  2299.      writehex       :  71  //        writehex(n, d)
  2300.      writeoct       :  72  //        writeoct(n, d)
  2301.      writes         :  73  //        writes(string)
  2302.      writef         :  74  //        writef(format, ..args..)
  2303.      capitalch      :  75  // ch  := capitalch(ch)
  2304.      compch         :  76  // res := compch(ch1, ch2)
  2305.      compstring     :  77  // res := compstring(s1, s2)
  2306.      rdargs         :  78  // res := rdargs(keys, v, upb)
  2307.      rditem         :  79  // res := rditem(v, upb)
  2308.      findarg        :  80  // res := findarg(keys, item)
  2309.      loadseg        :  81  // seg := loadseg(name)
  2310.      unloadseg      :  82  //        unloadseg(seg)
  2311.      callseg        :  83  // res := callseg(name,  ... args)
  2312.      tidyup         :  84  // Default tidyup routine
  2313.      datstring      :  85  // v   := datstring(v)
  2314.      datstamp       :  86  // v   := datstamp(v)
  2315.      killtask       :  87  // res := killtask(taskid)
  2316.      readnumber     :  88  // n   := readnumber(radix)
  2317.      findstring     :  89  // scb := findstring(string)
  2318.      deleteobj      :  90  // res := deleteobj(name)
  2319.      deletefile     :  90  // synonym
  2320.      renameobj      :  91  // res := renameobj(name1, name2)
  2321.      renamefile     :  91  // synonym
  2322. //     findupdate     :  92  // scb := findupdate(name)
  2323.      endstream      :  93  //        endstream(scb)
  2324.      get2bytes      :  94  // word:= get2bytes(v, wordoffset)
  2325.      put2bytes      :  95  //        put2bytes(v, wordoffset, word)
  2326.      vdu.movecursor :  96  //        vdu.movecursor(x,y)  [defined by user]
  2327.      vdu            :  97  // res := vdu(function)        [loaded by VDU cmd]
  2328.      vdu.rdch       :  98  // ch  := vdu.rdch(waitflag)   [defined by user]
  2329.      vdu.wrch       :  99  //        vdu.wrch(ch)         [defined by user]
  2330.      pktwait        : 100  // pkt := pktwait(dest, pkt)
  2331.      execute        : 101  // rc  := execute(string)
  2332.      devicetask     : 102  // id  := devicetask(name)
  2333. //103
  2334.      fault          : 104  //        fault(code)
  2335.      consoletask    : 105
  2336. //106
  2337.      splitname      : 107
  2338.      locateobj      : 108
  2339.      freeobj        : 109  //        freeobj(dir)
  2340. //110
  2341. //111
  2342. //     findobj        : 112
  2343.      copydir        : 113  // dir := copydir(dir)
  2344.      note           : 114  // res := note(scb, v)
  2345.      point          : 115  // res := point(scb, v)
  2346.      pointword      : 116  // res := pointword(wordoffset)
  2347.      fix            : 117  // int := fix (real)
  2348.      float          : 118  // real:= float(int)
  2349. //     readfp         : 119  // real := readfp()
  2350. //     writefp        : 120  // size := writefp(real,sig,tolerance)
  2351. //     initfp         : 121  //        initfp(vec)
  2352.      exception      : 122  //        exception vector for FP routines
  2353.      locatedir      : 123
  2354. //124
  2355.      createdir      : 125  // res := createdir(name)
  2356. //126-132 reserved for linking loader
  2357.      resident.table       : 126
  2358.      cli.defaultblocksize : 127
  2359.      overlay.error        : 128  // overlay.error(rc)
  2360. //133-149 defined in CLIHDR
  2361. $)
  2362.  
  2363. MANIFEST
  2364. $(
  2365.      FREEBIT             =     1
  2366.      SIZEBITS            =     #XFFFFFFFE
  2367.  
  2368.      ENDSTREAMCH         =     -1
  2369.      NOTINUSE            =     -1
  2370.      BYTESPERWORD        =     4
  2371.      BITSPERWORD         =     32
  2372.      BITSPERBYTE         =     8
  2373.      MAXINT              =     #X7FFFFFFF
  2374.      MININT              =     #X80000000
  2375.      TICKSPERSECOND      =     50
  2376.      MCADDRINC           =     4
  2377.      ROOTNODE            =     256
  2378.      UG                  =     150
  2379.      FG                  =     UG
  2380.      undefined.global    =     #X474C0001
  2381. $)
  2382.  
  2383.  
  2384. MANIFEST
  2385. $(
  2386.  
  2387.      // standard task numbers
  2388.      task.cli            =     1
  2389.      task.debug          =     2
  2390.      task.consolehandler =     3
  2391.      task.filehandler    =     4
  2392.  
  2393.      // states and flags
  2394.      state.pkt           =     1
  2395.      state.hold          =     2
  2396.      state.wait          =     4
  2397.      state.int           =   #10
  2398.      state.dead          =   #14
  2399.  
  2400.      flag.break          =     1
  2401.  
  2402.      // coroutine offsets -- added by MR 17/9/81
  2403.      co.cllr             =     1
  2404.      co.send             =     2
  2405.      co.resp             =     3
  2406.      co.func             =     4
  2407.  
  2408.      // standard packet offsets
  2409.      pkt.link            =     0
  2410.      pkt.devtaskid       =     1
  2411.      pkt.taskid          =     1
  2412.      pkt.devid           =     1
  2413.      pkt.id              =     1
  2414.      pkt.type            =     2
  2415.      pkt.res1            =     3
  2416.      pkt.res2            =     4
  2417.      pkt.arg1            =     5
  2418.      pkt.arg2            =     6
  2419.      pkt.arg3            =     7
  2420.      pkt.arg4            =     8
  2421.      pkt.arg5            =     9
  2422.      pkt.arg6            =    10
  2423.      pkt.arg7            =    11
  2424.  
  2425.      // Rootnode offsets.
  2426.      rtn.tasktab         =     0
  2427.      rtn.devtab          =     1
  2428.      rtn.tcblist         =     2
  2429.      rtn.crntask         =     3
  2430.      rtn.blklist         =     4
  2431.      rtn.debtask         =     5
  2432.      rtn.days            =     6
  2433.      rtn.mins            =     7
  2434.      rtn.ticks           =     8
  2435.      rtn.clwkq           =     9
  2436.      rtn.memsize         =    10
  2437.      rtn.info            =    11
  2438.      rtn.kstart          =    12
  2439.      rtn.upb             =    19
  2440.  
  2441.      // Rootnode info fields
  2442.      info.mctype         =     0
  2443.      info.assignments    =     1
  2444.      info.devices        =     2
  2445.      info.handlers       =     3
  2446.      info.ringhand       =     4
  2447.  
  2448.      // TCB offsets.
  2449.      tcb.link            =     0
  2450.      tcb.taskid          =     1
  2451.      tcb.pri             =     2
  2452.      tcb.wkq             =     3
  2453.      tcb.state           =     4
  2454.      tcb.flags           =     5
  2455.      tcb.stsiz           =     6
  2456.      tcb.seglist         =     7
  2457.      tcb.gbase           =     8
  2458.      tcb.sbase           =     9
  2459.      tcb.sp              =    10 // M/C dependent part
  2460.  
  2461.      tcb.upb             =   100
  2462.  
  2463.      // DCB offsets
  2464.      dcb.devid           =     1
  2465.      dcb.wkq             =     2
  2466. $)
  2467. ---------------------------------------- sys:g.prshdr
  2468. GLOBAL
  2469. $( parse : ug + 1
  2470.    istat : ug + 2
  2471.    trans : ug + 3
  2472.    state : ug + 4
  2473.    distat : ug + 5
  2474. $)
  2475. MANIFEST
  2476. $(
  2477.    it.any   = 1
  2478.    it.alpha = 2
  2479.    it.digit = 3
  2480.    it.lamda = 4
  2481.    it.numbr = 5
  2482.    it.dnumb = 6
  2483.    it.strng = 7
  2484.    it.blank = 8
  2485.    it.eos   = 9
  2486.    it.char  = 10
  2487.    it.key   = 11
  2488.    it.subxp = 12
  2489.    it.eol   = 13
  2490.    exit.state = -1
  2491.    f.bsupp  = 1
  2492.    err.no.workspace = -1
  2493.    err.not.initialised = -2
  2494.    err.bad.parse = -3
  2495.    err.bad.state = -4
  2496.    err.no.state = -5
  2497.    err.initialised = -6
  2498.    err.bad.backtrack = -7
  2499. $)
  2500. ---------------------------------------- parser
  2501. SECTION "PARSER"
  2502. /*
  2503.    Table driven parser by C.G. Selwyn 19-MAR-84
  2504.       based on TPARS running on RSX-11M
  2505.  
  2506.    There are five user callable routines :-
  2507.  
  2508. 1) ISTAT(n) -    Where 'n' is the amount of workspace to be used
  2509.                   by the parser
  2510.  
  2511. 2) STATE(name) - Where 'name' is a value by which a state is to be
  2512.                   referenced.
  2513.  
  2514. 3) TRANS(fname,tname,item.type,item.value,action,id)
  2515.            Where 'fname' to 'tname' describes a state transition.
  2516.  
  2517.                  'item.type' is the type of match to be made if this
  2518.                   transition is to occur.
  2519.  
  2520.                  'item.value' is the value of the item to be matched
  2521.                   if appropriate.
  2522.  
  2523.                  This parameter may have the values :-
  2524.                   it.any   - Will match any character except it.eos or it.eol.
  2525.                   it.alpha - Will match any alphabetic character.
  2526.                   it.digit - Will match any digit (0-9).
  2527.                   it.lamda - Is an automatic match.
  2528.                   it.numbr - Will match a number.
  2529.                               The syntax of numbers is -
  2530.                                ddd   - Decimal no.
  2531.                                #ooo  - Octal no.
  2532.                                #Xhhh - Hexadecimal no.
  2533.                   it.dnumb - Will match a decimal no.
  2534.                   it.strng - Will match any alphameric string (never null).
  2535.                   it.blank - Will match a blank character.
  2536.                   it.eos   - Will match the end of stream character.
  2537.                   it.eol   - Will match the end of line character.
  2538.                   it.char  - Will match the given character.
  2539.                   it.key   - Will match the given keystring.
  2540.                   it.subxp - Will match a subexpression.
  2541.  
  2542.                  'action' is the address of an action routine to be called
  2543.                   if the item.type and value are matched. This routine should
  2544.                   return a result to indicate whether a transition is to be
  2545.                   rejected (a FALSE result will reject). If not required it
  2546.                   should be set to 0.
  2547.  
  2548.                  'id' is a user supplied parameter by which he may identify
  2549.                   the transition (see below).
  2550.  
  2551.                  The parameters passed by the parser are :-
  2552.                   arg1 - The line buffer pointer.
  2553.                   arg2 - The byte offset to the part of the line matched by
  2554.                           the current transition.
  2555.                   arg3 - The length of the above string.
  2556.                   arg4 - The value of the match (if appropriate e.g. a number..)
  2557.                   arg5 - The user supplied id parameter.
  2558.                   arg6 - The address of the flags word for dynamic changing
  2559.                           of the flags options if required.
  2560.  
  2561. 4) success := PARSE(isname,rdch.routine,flags,debug.routine)
  2562.            Where 'isname' is the initial state name.
  2563.  
  2564.                  'rdch.routine' is the address of a routine which returns the
  2565.                   next character on the input stream.
  2566.  
  2567.                  'flags' is a word containing control flags to the parser.
  2568.                   The bit assignments are as follows :-
  2569.                    Bit 0 - Blank suppression.
  2570.  
  2571.                  'debug.routine' is the address of a routine to be called
  2572.                   on each transition. If not required it should be set to 0.
  2573.                   The arguments are :-
  2574.                    i) The 'from' state name.
  2575.                   ii) The 'to' state name.
  2576.  
  2577.                  'success' is the result showing whether the parse succeeded or
  2578.                   failed.
  2579.  
  2580. NOTE :
  2581.    The above functions all return a result to indicate success of operation.
  2582.    If the result is FALSE 'result2' is set to the reason why :-
  2583.     err.no.workspace       - Run out of workspace.
  2584.     err.no.state           - The destination state was not found.
  2585.     err.bad.state          - The item type in the state was invalid.
  2586.     err.bad.parse          - The parse failed.
  2587.     err.not.initialised    - The state table has not been initialised.
  2588.     err.initialised        - The state table has already been initialised.
  2589.     err.bad.backtrack      - A transition rejection has caused a backtrack
  2590.                               across an eol boundary.
  2591. 5) r := DISTAT()
  2592.            Where 'r' is the % of workspace used.
  2593. */
  2594.  
  2595. GET "libhdr"
  2596. GET "prshdr"
  2597.  
  2598. MANIFEST
  2599. $( t.link = 0
  2600.    t.dest = 1
  2601.    t.type = 2
  2602.    t.act  = 3
  2603.    t.id   = 4
  2604.    t.val  = 5
  2605.    t.upb  = 5
  2606.    s.link = 0
  2607.    s.name = 1
  2608.    s.trns = 2
  2609.    s.upb  = 2
  2610. $)
  2611.  
  2612. STATIC
  2613. $( tbuf = 0
  2614.    tbufsize = 0
  2615.    tbuftop = 0
  2616.    lbuf = 0
  2617.    lbufptr = 0
  2618.    flags = 0
  2619.    statevec = 0
  2620.    user.rdch = 0
  2621.    ex.p = 0
  2622.    ex.l = 0
  2623.    user.debug = 0
  2624.    newl.global = FALSE
  2625. $)
  2626.  
  2627. LET add.to.q(tvec,s) BE
  2628. $( UNTIL !tvec = 0 DO tvec := !tvec
  2629.    !tvec := s
  2630.    s!0 := 0
  2631. $)
  2632.  
  2633. LET getblk(n) = VALOF
  2634. $( LET r = tbuftop
  2635.    LET ntop = tbuftop+n+1
  2636.  
  2637.    IF ntop > tbuf+tbufsize THEN
  2638.    $( result2 := err.no.workspace
  2639.       longjump(ex.p,ex.l)
  2640.    $)
  2641.    tbuftop := ntop
  2642.    RESULTIS r
  2643. $)
  2644.  
  2645. LET istat(n) = VALOF
  2646. $( IF tbuf ~= 0 THEN
  2647.    $( result2 := err.initialised
  2648.       RESULTIS FALSE
  2649.    $)
  2650.    tbuf := getvec(n)
  2651.    tbufsize := n
  2652.    tbuftop := tbuf
  2653.    lbuf := 0
  2654.    lbufptr := 1
  2655.    flags := 0
  2656.    statevec := getblk(9)
  2657.    FOR i = 0 TO 9 DO statevec!i := 0
  2658.    lbuf := getblk(80/bytesperword)
  2659.    user.rdch := 0
  2660.    RESULTIS TRUE
  2661. $)
  2662.  
  2663. LET distat() = VALOF
  2664. $( LET r = ?
  2665.    IF tbuf = 0 THEN RESULTIS 0
  2666.    freevec(tbuf)
  2667.    r := ((tbuftop-tbuf)*100)/tbufsize
  2668.    tbuf := 0
  2669.    RESULTIS r
  2670. $)
  2671.  
  2672. LET copystring(v) = VALOF
  2673. $( LET v1 = getblk((v%0)/4)
  2674.    FOR i = 0 TO v%0 DO v1%i := v%i
  2675.    RESULTIS v1
  2676. $)
  2677.  
  2678. LET state(sname) = VALOF
  2679. $( LET r = ?
  2680.    ex.p := level()
  2681.    ex.l := exit.l
  2682.    r := getblk(s.upb)
  2683.    add.to.q(statevec+(ABS sname REM 10),r)
  2684.    r!s.name := sname
  2685.    r!s.trns := 0
  2686.    RESULTIS TRUE
  2687. exit.l:
  2688.    RESULTIS FALSE
  2689. $)
  2690.  
  2691. LET findstate(sname) = VALOF
  2692. $( LET s = statevec + (ABS sname REM 10)
  2693.    IF sname = exit.state THEN RESULTIS exit.state
  2694.    UNTIL s = 0 DO
  2695.    $( IF sname = s!s.name THEN RESULTIS s
  2696.       s := !s
  2697.    $)
  2698.    result2 := err.no.state
  2699.    longjump(ex.p,ex.l)
  2700.    RESULTIS 0
  2701. $)
  2702.  
  2703. LET trans(sname,tname,itype,v,action,id) = VALOF
  2704. $( LET tvec,s = ?,?
  2705.    LET blkl = ?
  2706.    ex.p := level()
  2707.    ex.l := exit.l
  2708.  
  2709.    blkl := (itype=it.key)|(itype=it.char)|(itype=it.subxp) ->t.upb,t.upb-1
  2710.    tvec := getblk(blkl)
  2711.  
  2712.    s := findstate(sname)
  2713.    add.to.q(s+s.trns,tvec)
  2714.    tvec!t.dest := tname
  2715.    tvec!t.type := itype
  2716.    IF itype = it.key THEN v := copystring(v)
  2717.    tvec!t.val := v
  2718.    tvec!t.act := action
  2719.    tvec!t.id := id
  2720.    RESULTIS TRUE
  2721. exit.l:
  2722.    RESULTIS FALSE
  2723. $)
  2724.  
  2725. LET readnumber(radix) = VALOF
  2726. $( LET sum, ch = 0, 0
  2727.    AND neg = FALSE
  2728.  
  2729.    $( ch := capitalch(rdch())
  2730.       SWITCHON ch INTO
  2731.       $( DEFAULT:    BREAK
  2732.          CASE '-':  neg := TRUE
  2733.          CASE '+':  ch := rdch()
  2734.                     BREAK
  2735.          CASE '*S':
  2736.          CASE '*T':
  2737.          CASE '*N':
  2738.          CASE '*P':
  2739.       $)
  2740.    $) REPEAT
  2741.  
  2742.    $( LET c = '0' <= ch <= '9' -> ch-'0',
  2743.               'A' <= ch <= 'Z' -> ch-'A'+10 , 100
  2744.       IF c >= radix DO $( unrdch() ; RESULTIS neg -> -sum,sum $)
  2745.       sum := sum*radix + c
  2746.       ch := capitalch(rdch())
  2747.    $) REPEAT
  2748. $)
  2749.  
  2750. LET my.unrdch() = VALOF
  2751. $( IF lbufptr = 1 THEN RESULTIS FALSE
  2752.    lbufptr := lbufptr-1
  2753.    RESULTIS TRUE
  2754. $)
  2755.  
  2756. LET my.rdch() = VALOF
  2757. $( LET ch = ?
  2758.    TEST lbufptr <= lbuf%0 THEN
  2759.    $( ch := lbuf%lbufptr
  2760.       lbufptr := lbufptr + 1
  2761.    $)
  2762.    ELSE
  2763.    $( ch := user.rdch()
  2764.       UNLESS ch = endstreamch DO
  2765.       $( lbuf%lbufptr := ch
  2766.          lbuf%0 := lbufptr
  2767.          lbufptr := lbufptr+1
  2768.       $)
  2769.    $)
  2770.    RESULTIS capitalch(ch)
  2771. $)
  2772.  
  2773. LET blank(ch) = ch = '*S' | ch = '*T'
  2774. LET alpha(ch) = 'A' <= capitalch(ch) <= 'Z'
  2775. LET numeric(ch) = '0' <= ch <= '9'
  2776. LET alphameric(ch) = alpha(ch) | numeric(ch)
  2777.  
  2778. LET chk.any() = VALOF
  2779. $( result2  := rdch()
  2780.    RESULTIS (result2 ~= endstreamch) & (result2 ~= '*N')
  2781. $)
  2782.  
  2783. LET chk.alpha() = VALOF
  2784. $( result2 := rdch()
  2785.    RESULTIS alpha(result2)
  2786. $)
  2787.  
  2788. LET chk.digit() = VALOF
  2789. $( result2 := rdch()
  2790.    RESULTIS numeric(result2)
  2791. $)
  2792.  
  2793. LET chk.numbr() = VALOF
  2794. $( LET ch = rdch()
  2795.    LET base = 10
  2796.    TEST ch = '#' THEN
  2797.    $( base := 8
  2798.       ch := rdch()
  2799.       TEST ch = 'X' THEN
  2800.       $( ch := rdch()
  2801.          TEST numeric(ch) | 'A' <= ch <= 'F' THEN
  2802.          $( base := 16
  2803.             unrdch()
  2804.          $)
  2805.          ELSE RESULTIS FALSE
  2806.       $)
  2807.       ELSE
  2808.       $( TEST '0'<=ch<='7' THEN unrdch()
  2809.          ELSE RESULTIS FALSE
  2810.       $)
  2811.    $)
  2812.    ELSE
  2813.    $( TEST numeric(ch) THEN unrdch()
  2814.       ELSE RESULTIS FALSE
  2815.    $)
  2816.    result2 := readnumber(base)
  2817.    RESULTIS TRUE
  2818. $)
  2819.  
  2820. LET chk.dnumb() = VALOF
  2821. $( LET ch = rdch()
  2822.    IF numeric(ch) THEN
  2823.    $( unrdch()
  2824.       result2 := readn()
  2825.       RESULTIS TRUE
  2826.    $)
  2827.    RESULTIS FALSE
  2828. $)
  2829.  
  2830. LET chk.strng() = VALOF
  2831. $( LET lstr = 0
  2832.    LET ch = rdch()
  2833.    UNTIL ~alphameric(ch) DO
  2834.    $( lstr := lstr +1
  2835.       ch := rdch()
  2836.    $)
  2837.    unrdch()
  2838.    RESULTIS lstr ~= 0
  2839. $)
  2840.  
  2841. LET chk.blank() = VALOF
  2842. $( IF ~blank(rdch()) THEN RESULTIS FALSE
  2843.    UNTIL ~blank(rdch()) LOOP
  2844.    unrdch()
  2845.    RESULTIS TRUE
  2846. $)
  2847.  
  2848. LET chk.eos() = rdch() = endstreamch
  2849.  
  2850. LET chk.eol() = rdch() = '*N'
  2851.  
  2852. LET chk.char(c) = rdch() = capitalch(c)
  2853.  
  2854. LET chk.key(s) = VALOF
  2855. $( LET ch = ?
  2856.    LET r = ?
  2857.    FOR i = 1 TO s%0 DO
  2858.    $( ch := rdch()
  2859.       IF ch ~= capitalch(s%i) THEN RESULTIS FALSE
  2860.    $)
  2861.    r := ~alphameric(rdch())
  2862.    unrdch()
  2863.    RESULTIS r
  2864. $)
  2865.  
  2866. LET check.input(ctrans) = VALOF
  2867. $( LET succeed = ?
  2868.    LET lbstart = ?
  2869.  
  2870.    IF (lbuf%(lbuf%0) = '*N')&(lbufptr > lbuf%0) THEN
  2871.    $( lbuf%0 := 0
  2872.       lbufptr := 1
  2873.       newl.global := TRUE
  2874.    $)
  2875. //
  2876. // If blank suppression then do so
  2877. //
  2878.    IF (ctrans!t.type ~= it.lamda)&((flags&f.bsupp)~=0) THEN
  2879.    $( $( LET ch = my.rdch()
  2880.          IF ~blank(ch) THEN BREAK
  2881.       $) REPEAT
  2882.       unrdch()
  2883.    $)
  2884.  
  2885.    lbstart := lbufptr
  2886.    SWITCHON ctrans!t.type INTO
  2887.    $(
  2888.    CASE it.any   :
  2889.       succeed := chk.any()
  2890.       ENDCASE
  2891.    CASE it.alpha :
  2892.       succeed := chk.alpha()
  2893.       ENDCASE
  2894.    CASE it.digit :
  2895.       succeed := chk.digit()
  2896.       ENDCASE
  2897.    CASE it.lamda :
  2898.       succeed := TRUE
  2899.       ENDCASE
  2900.    CASE it.numbr :
  2901.       succeed := chk.numbr()
  2902.       ENDCASE
  2903.    CASE it.dnumb :
  2904.       succeed := chk.dnumb()
  2905.       ENDCASE
  2906.    CASE it.strng :
  2907.       succeed := chk.strng()
  2908.       ENDCASE
  2909.    CASE it.blank :
  2910.       succeed := chk.blank()
  2911.       ENDCASE
  2912.    CASE it.eos   :
  2913.       succeed := chk.eos()
  2914.       ENDCASE
  2915.    CASE it.eol   :
  2916.       succeed := chk.eol()
  2917.       ENDCASE
  2918.    CASE it.char  :
  2919.       succeed := chk.char(ctrans!t.val)
  2920.       ENDCASE
  2921.    CASE it.key   :
  2922.       succeed := chk.key(ctrans!t.val)
  2923.       ENDCASE
  2924.    CASE it.subxp :
  2925.       succeed := do.parse(ctrans!t.val)
  2926.       ENDCASE
  2927.    DEFAULT :
  2928.       result2 := err.bad.state
  2929.       longjump(ex.p,ex.l)
  2930.    $)
  2931.  
  2932.    TEST succeed THEN
  2933.       IF (ctrans!t.act ~= 0) THEN
  2934.       $( LET arg1 = lbuf
  2935.          LET arg2 = newl.global -> 1,lbstart
  2936.          LET arg3 = lbufptr - arg2
  2937.          LET arg4 = result2
  2938.          LET arg5 = ctrans!t.id
  2939.          LET arg6 = @flags
  2940.          succeed := (ctrans!t.act)(arg1,arg2,arg3,arg4,arg5,arg6)
  2941.       $)
  2942.    ELSE lbufptr := lbstart
  2943.    RESULTIS succeed
  2944. $)
  2945.  
  2946. AND do.parse(isname) = VALOF
  2947. $( LET cstate = findstate(isname)
  2948.    LET newl.local = newl.global
  2949.    newl.global := FALSE
  2950.  
  2951.    UNTIL cstate = exit.state DO
  2952.    $( LET ctrans = ?
  2953.       ctrans := cstate!s.trns
  2954.       UNTIL ctrans = 0 DO
  2955.       $( IF check.input(ctrans) THEN
  2956.          $( LET nstate = findstate(ctrans!t.dest)
  2957.             IF user.debug ~=0 THEN
  2958.                user.debug(cstate!s.name,
  2959.                                nstate = exit.state -> exit.state,nstate!s.name)
  2960.             cstate := nstate
  2961.             BREAK
  2962.          $)
  2963.          ctrans := !ctrans
  2964.       $)
  2965.       newl.global := newl.global | newl.local
  2966.  
  2967.       IF (ctrans = 0) THEN
  2968.       $( IF newl.global THEN
  2969.          $( result2 := err.bad.backtrack
  2970.             longjump(ex.p,ex.l)
  2971.          $)
  2972.          RESULTIS FALSE
  2973.       $)
  2974.    $)
  2975.    RESULTIS TRUE
  2976. $)
  2977.  
  2978. LET parse(isname,rdchrtn,f,drtn) = VALOF
  2979. $( LET cstate,ctrans = ?,?
  2980.    LET succeed = ?
  2981.    LET sys.rdch,sys.unrdch = ?,?
  2982.    LET r = ?
  2983.  
  2984.    ex.l := exit.l
  2985.    ex.p := level()
  2986.  
  2987.    IF tbuf ~= 0 THEN
  2988.    $( sys.rdch := rdch
  2989.       sys.unrdch := unrdch
  2990.       flags := f
  2991.       user.debug := drtn
  2992.       newl.global := FALSE
  2993.  
  2994.       user.rdch := rdchrtn
  2995.       rdch := my.rdch
  2996.       unrdch := my.unrdch
  2997.       lbufptr := 1
  2998.       lbuf%0 := 0
  2999.       r := do.parse(isname)
  3000.       rdch := sys.rdch
  3001.       unrdch := sys.unrdch
  3002.       result2 := err.bad.parse
  3003.       RESULTIS r
  3004.    $)
  3005.    result2 := err.not.initialised
  3006.    RESULTIS FALSE
  3007. exit.l:
  3008.    rdch := sys.rdch
  3009.    unrdch := sys.unrdch
  3010.    RESULTIS FALSE
  3011. $)
  3012.